#!/usr/bin/env ruby
# -*- f90 -*-
# vi: set sw=4 ts=8:
require("intrinsic_types")
require("optparse")
#
# "dc_test.f90" Generator with Ruby.
#
opt = OptionParser.new
opt.on('--max_dim=VAL') {|v| $max_dim = v.to_i}
opt.parse!(ARGV)
$max_dim = 7 unless $max_dim
print <<"__EndOfFortran90Code__"
!--
#{rb2f90_header_comment}!
!++
!
!= テストプログラム作成支援
!
!= Support making test programs
!
! Authors:: Yasuhiro MORIKAWA
! Version:: $Id: dc_test.rb2f90,v 1.17 2007/08/15 18:54:43 morikawa Exp $
! Tag Name:: $Name: gt4f90io-20070824 $
! 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 〜 #{$max_dim}次元) を与えることができます.
! 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 - #{$max_dim}) 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*.
!
!
!=== 負の値の取り扱い
!=== Treatment of negative values
!
! 比較される *answer* の値と *check* の値が両方とも負の場合,
! AssertGreaterThan および AssertLessThan は 2 つの値の絶対値の
! 比較を行います. エラーメッセージは以下のようになります.
! オプショナル引数 *negative_support* に .false. を与える場合,
! 絶対値での比較を行いません.
!
! "AssertGreaterThan" and "AssertLessThan" compare absolute values
! of *answer* and *check* when both compared two values are negative.
! In this case, error message is as follows.
! When an optional argument *negative_support* is .false.,
! the comparison with absolute values is not done.
!
! ABSOLUTE value of check(14,1) = -1.189774221E-09
! is NOT LESS THAN
! ABSOLUTE value of answer(14,1) = -1.189774405E-09
!
!
!=== 使用例
!=== Example
!
! 使用例は以下の通りです.
!
! 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, negative_support=.true.)
! 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
#{foreach("\\$type\\$", "Char", "Int", "Real", "Double", %Q{
#{forloop("\\$num\\$", 0, $max_dim, %Q{
module procedure DCTestAssertEqual$type$$num$
})}
})}
#{forloop("\\$num\\$", 0, $max_dim, %Q{
module procedure DCTestAssertEqualLogical$num$
})}
end interface
interface AssertGreaterThan
#{foreach("\\$type\\$", "Int", "Real", "Double", %Q{
#{forloop("\\$num\\$", 0, $max_dim, %Q{
module procedure DCTestAssertGreaterThan$type$$num$
})}
})}
end interface
interface AssertLessThan
#{foreach("\\$type\\$", "Int", "Real", "Double", %Q{
#{forloop("\\$num\\$", 0, $max_dim, %Q{
module procedure DCTestAssertLessThan$type$$num$
})}
})}
end interface
contains
__EndOfFortran90Code__
############################################################
# AssertEqual
types = ["Char", "Int", "Real", "Double"]
def trim(type, value)
return "trim(#{value})" if type == "Char"
return value
end
types.each{ |type|
for num in 0..$max_dim
print <<"__EndOfFortran90Code__"
subroutine DCTestAssertEqual#{type}#{num}(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
#{$type_intent_in[type]}, intent(in):: answer#{array_colon("#{num}")}
#{$type_intent_in[type]}, intent(in):: check#{array_colon("#{num}")}
logical :: err_flag
character(STRING) :: pos_str
#{$type_internal[type]} :: wrong, right
#{ifelse(num, 0, %Q{
}, %Q{
integer :: answer_shape(#{num}), check_shape(#{num}), pos(#{num})
logical :: consist_shape(#{num})
character(TOKEN) :: pos_array(#{num})
integer, allocatable :: mask_array#{array_colon("#{num}")}
logical, allocatable :: judge#{array_colon("#{num}")}
logical, allocatable :: judge_rev#{array_colon("#{num}")}
})}
#{ifelse(type, "Char", %Q{
#{ifelse(num, 0, %Q{
}, %Q{
#{$type_internal[type]}, allocatable :: answer_fixed_length#{array_colon("#{num}")}
#{$type_internal[type]}, allocatable :: check_fixed_length#{array_colon("#{num}")}
})}
})}
continue
err_flag = .false.
#{ifelse(num, 0, %Q{
err_flag = .not. #{trim(type, "answer")} == #{trim(type, "check")}
wrong = check
right = answer
pos_str = ''
}, %Q{
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 (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( judge (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( judge_rev (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
#{ifelse(type, "Char", %Q{
allocate( answer_fixed_length (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( check_fixed_length (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& check_shape($dimnum$), &
})}
& check_shape(#{num}) ) &
& )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
}, %Q{
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 (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) )
right = answer (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) )
#{forloop("\\$dimnum\\$", 1, num, %Q{
write(unit=pos_array($dimnum$), fmt="(i20)") pos($dimnum$)
})}
pos_str = '(' // &
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& trim(adjustl(pos_array($dimnum$))) // ',' // &
})}
& trim(adjustl(pos_array(#{num}))) // ')'
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(type, "wrong")}
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', #{trim(type, "right")}
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqual#{type}#{num}
__EndOfFortran90Code__
end
}
for num in 0..$max_dim
print <<"__EndOfFortran90Code__"
subroutine DCTestAssertEqualLogical#{num}(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer#{array_colon("#{num}")}
logical, intent(in):: check#{array_colon("#{num}")}
#{ifelse(num, 0, %Q{
character(STRING) :: answer_str
character(STRING) :: check_str
}, %Q{
integer :: answer_shape(#{num}), check_shape(#{num}), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str#{array_colon("#{num}")}
character(STRING), allocatable :: check_str#{array_colon("#{num}")}
})}
continue
#{ifelse(num, 0, %Q{
if (answer) then
answer_str = ".true."
else
answer_str = ".false."
end if
if (check) then
check_str = ".true."
else
check_str = ".false."
end if
}, %Q{
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 (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( check_str (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& check_shape($dimnum$), &
})}
& check_shape(#{num}) ) &
& )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
})}
call DCTestAssertEqualChar#{num}(message, answer_str, check_str)
#{ifelse(num, 0, %Q{
}, %Q{
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
})}
end subroutine DCTestAssertEqualLogical#{num}
__EndOfFortran90Code__
end
############################################################
# AssertGreaterThan
types = ["Int", "Real", "Double"]
def trim(type, value)
return value
end
types.each{ |type|
for num in 0..$max_dim
print <<"__EndOfFortran90Code__"
subroutine DCTestAssertGreaterThan#{type}#{num}( &
& message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
#{$type_intent_in[type]}, intent(in):: answer#{array_colon("#{num}")}
#{$type_intent_in[type]}, intent(in):: check#{array_colon("#{num}")}
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
#{$type_internal[type]}:: wrong, right
#{ifelse(num, 0, %Q{
}, %Q{
integer:: answer_shape(#{num}), check_shape(#{num}), pos(#{num})
logical:: consist_shape(#{num})
character(TOKEN):: pos_array(#{num})
integer, allocatable:: mask_array#{array_colon("#{num}")}
logical, allocatable:: judge#{array_colon("#{num}")}
logical, allocatable:: judge_rev#{array_colon("#{num}")}
logical, allocatable:: answer_negative#{array_colon("#{num}")}
logical, allocatable:: check_negative#{array_colon("#{num}")}
logical, allocatable:: both_negative#{array_colon("#{num}")}
})}
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
#{ifelse(num, 0, %Q{
err_flag = .not. #{trim(type, "answer")} < #{trim(type, "check")}
abs_mes = ''
if ( #{trim(type, "answer")} < 0#{$type_numsuf[type]} &
& .and. #{trim(type, "check")} < 0#{$type_numsuf[type]} &
& .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
}, %Q{
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 (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( judge (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( judge_rev (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( answer_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( check_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( both_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
answer_negative = answer < 0#{$type_numsuf[type]}
check_negative = check < 0#{$type_numsuf[type]}
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) )
right = answer (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) )
#{forloop("\\$dimnum\\$", 1, num, %Q{
write(unit=pos_array($dimnum$), fmt="(i20)") pos($dimnum$)
})}
pos_str = '(' // &
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& trim(adjustl(pos_array($dimnum$))) // ',' // &
})}
& trim(adjustl(pos_array(#{num}))) // ')'
if ( both_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
})}
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // &
& ' check' // trim(pos_str) // ' = ', #{trim(type, "wrong")}
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // &
& ' answer' // trim(pos_str) // ' = ', #{trim(type, "right")}
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThan#{type}#{num}
__EndOfFortran90Code__
end
}
############################################################
# AssertLessThan
types = ["Int", "Real", "Double"]
def trim(type, value)
return value
end
types.each{ |type|
for num in 0..$max_dim
print <<"__EndOfFortran90Code__"
subroutine DCTestAssertLessThan#{type}#{num}( &
& message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
#{$type_intent_in[type]}, intent(in):: answer#{array_colon("#{num}")}
#{$type_intent_in[type]}, intent(in):: check#{array_colon("#{num}")}
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
#{$type_internal[type]}:: wrong, right
#{ifelse(num, 0, %Q{
}, %Q{
integer:: answer_shape(#{num}), check_shape(#{num}), pos(#{num})
logical:: consist_shape(#{num})
character(TOKEN):: pos_array(#{num})
integer, allocatable:: mask_array#{array_colon("#{num}")}
logical, allocatable:: judge#{array_colon("#{num}")}
logical, allocatable:: judge_rev#{array_colon("#{num}")}
logical, allocatable:: answer_negative#{array_colon("#{num}")}
logical, allocatable:: check_negative#{array_colon("#{num}")}
logical, allocatable:: both_negative#{array_colon("#{num}")}
})}
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
#{ifelse(num, 0, %Q{
err_flag = .not. #{trim(type, "answer")} > #{trim(type, "check")}
abs_mes = ''
if ( #{trim(type, "answer")} < 0#{$type_numsuf[type]} &
& .and. #{trim(type, "check")} < 0#{$type_numsuf[type]} &
& .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
}, %Q{
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 (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( judge (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( judge_rev (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( answer_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( check_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
allocate( both_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& answer_shape($dimnum$), &
})}
& answer_shape(#{num}) ) &
& )
answer_negative = answer < 0#{$type_numsuf[type]}
check_negative = check < 0#{$type_numsuf[type]}
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) )
right = answer (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) )
#{forloop("\\$dimnum\\$", 1, num, %Q{
write(unit=pos_array($dimnum$), fmt="(i20)") pos($dimnum$)
})}
pos_str = '(' // &
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& trim(adjustl(pos_array($dimnum$))) // ',' // &
})}
& trim(adjustl(pos_array(#{num}))) // ')'
if ( both_negative (&
#{forloop("\\$dimnum\\$", 1, num-1, %Q{
& pos($dimnum$), &
})}
& pos(#{num}) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
})}
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // &
& ' check' // trim(pos_str) // ' = ', #{trim(type, "wrong")}
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // &
& ' answer' // trim(pos_str) // ' = ', #{trim(type, "right")}
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThan#{type}#{num}
__EndOfFortran90Code__
end
}
print <<"__EndOfFortran90Code__"
end module dc_test
__EndOfFortran90Code__
print <<"__EndOfFooter__"
!--
! vi:set readonly sw=4 ts=8:
!
#{rb2f90_emacs_readonly}!
!++
__EndOfFooter__