!-- ! *** 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.18 2007-09-13 08:57:14 morikawa Exp $ ! Tag Name:: $Name: gt4f90io-20080810 $ ! 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.0, 2.0 /) ! call AssertEqual(message='String test', answer='foo', check=str1) ! call AssertEqual(message='Float test', & ! & answer=(/1.0, 2.0/), check=r1) ! end program test ! ! ! *check* と *answer* との値, および配列のサイズが一致する場合に ! テストプログラムは「Checking <*message* に与えられた文字> OK」 ! というメッセージを表示します. プログラムは続行します. ! AssertEqual の代わりに AssertGreaterThan を使用する場合には ! *check* が *answer* よりも大きい場合, ! AssertLessThan を使用する場合には *check* が *answer* よりも小さい場合に ! プログラムは続行します. ! ! 一方で *answer* と *check* の値, もしくは配列のサイズが異なる場合には, ! テストプログラムは「Checking <*message* に与えられた文字> FAILURE」 ! というメッセージを表示します. プログラムはエラーを発生させて終了します. ! AssertEqual の代わりに AssertGreaterThan を使用する場合には ! *check* が *answer* よりも大きくない場合, ! AssertLessThan を使用する場合には *check* が *answer* よりも ! 小さくない場合にプログラムは終了します. ! ! ! When the values and array sizes of *check* and *answer* are same, ! the test program displays a message ! "Checking 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*. ! ! !=== 精度の指定 !=== Specification of accuracy ! ! 単精度実数型, 倍精度実数型同士の比較において, ! 丸め誤差や情報落ち誤差を考慮したい場合には, ! 引数 *significant_digits*, *ignore_digits* に整数型を与えてください. ! *significant_digits* には有効数字の桁数を, *ignore_digits* には ! 無視するオーダーを与えます. 以下の例では, 有効数字の桁数を 7 とし, ! 1.0e-6 以下の数値を無視して値の比較を行っています. ! ! About comparison of single precision reals or double precision reals, ! in order to consider rounding errors and information loss errors, ! specify integer to *significant_digits*, *ignore_digits* arguments. ! Specify significant digits to *significant_digits*, and ! negligible order to *ignore_digits*. ! In the following example, significant digits is 7, and ! numerical value less than 1.0e-6 is ignored. ! ! program test2 ! use dc_test, only: AssertEqual ! implicit none ! real:: numd1(2,3) ! ! numd1 = reshape((/-19.432, 75.3, 3.183, & ! & 0.023, -0.9, 328.2/), & ! & (/2,3/)) ! ! call AssertEqual( 'Float (single precision) test', & ! & answer = numd1, & ! & check = ( numd1 / 3.0 ) * 3.0, & ! & significant_digits = 7, ignore_digits = -6 ) ! ! end program test2 ! ! !=== 負の値の取り扱い !=== 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 ! implicit none ! character(STRING):: str1, str2 ! real:: r1(2) ! integer:: int1 ! real:: numr1(2) ! real(DP):: numd1(2,3), numd2(2,3) ! logical:: y_n ! continue ! ! str1 = 'foo' ! r1 = (/ 1.0_DP, 2.0_DP /) ! call AssertEqual( message = 'String test', answer = 'foo', check = str1 ) ! call AssertEqual( message = 'Float test', & ! & answer = (/1.0e0, 2.0e0/), check = r1 ) ! ! str2 = "foo" ! call AssertEqual( 'Character test', answer = 'foo', check = str2 ) ! int1 = 1 ! call AssertEqual( 'Integer test', answer = 1, check = int1 ) ! numr1(:) = (/ 0.001235423, 0.248271 /) ! call AssertGreaterThan( 'Float test 1', & ! & answer = (/ 0.00061771142, 0.1241354 /), check = numr1 / 2.0 ) ! call AssertLessThan( 'Float test 2', & ! & answer = (/ 0.00061771158, 0.1241358 /), check = numr1 / 2.0 ) ! y_n = .true. ! call AssertEqual( 'Logical test', answer = .true., check = y_n ) ! ! numd1 = reshape( (/ -19.432_DP, 75.3_DP, 3.183_DP, & ! & 0.023_DP, -0.9_DP, 328.2_DP /), & ! & (/ 2,3 /) ) ! call AssertGreaterThan( 'Double precision test 1', & ! & answer = reshape( (/ -38.8639_DP, 150.5999_DP, 6.365999_DP, & ! & 0.0459999_DP, -1.7999_DP, 656.3999_DP /), & ! & (/ 2,3 /) ), & ! & check = numd1*2.0_DP ) ! call AssertLessThan( 'Double precision test 2', & ! & answer = reshape( (/ -38.86401_DP, 150.60001_DP, 6.3660001_DP, & ! & 0.04600001_DP, -1.8000001_DP, 656.6_DP /), & ! & (/ 2,3 /) ), & ! & check = numd1*2.0_DP, negative_support=.true. ) ! ! call AssertEqual( 'Double precision test 3', & ! & answer = numd1, & ! & check = ( numd1 / 3.0_DP ) * 3.0_DP, & ! & significant_digits = 10, ignore_digits = -10 ) ! ! numd2 = reshape( (/ 19.4e+7_DP, 75.3_DP, 3.18e-7_DP, & ! & 0.023e-7_DP, 0.9e+7_DP, 328.2_DP /), & ! & (/ 2,3 /) ) ! ! call AssertEqual( 'Double precision test 4', & ! & answer = numd2, & ! & check = ( ( ( numd2 + 0.008_DP - 0.008_DP ) / 1.5_DP ) * 3.0_DP ) / 2.0_DP, & ! & significant_digits = 10, ignore_digits = -15 ) ! ! call AssertEqual( 'Double precision test 5', & ! & answer = numd2, & ! & check = ( ( ( numd2 + 0.008_DP - 0.008_DP ) / 1.5_DP ) * 3.0_DP ) / 2.0_DP, & ! & significant_digits = 15, ignore_digits = -19 ) ! ! end program test_sample ! ! ! 上記の例では, 最後のテストで敢えて小さすぎる値を無視するオーダー ! として設定しているため, 以下のようなメッセージを出力して ! プログラムは強制終了します. ! ! In above example, too small negligible order is specified on purpose ! in the last test. Then the program displays a following message, ! and aborts. ! ! *** MESSAGE [AssertEQ] *** Checking String test OK ! *** MESSAGE [AssertEQ] *** Checking Float test OK ! *** MESSAGE [AssertEQ] *** Checking Character test OK ! *** MESSAGE [AssertEQ] *** Checking Integer test OK ! *** MESSAGE [AssertGT] *** Checking Float test 1 OK ! *** MESSAGE [AssertLT] *** Checking Float test 2 OK ! *** MESSAGE [AssertEQ] *** Checking Logical test OK ! *** MESSAGE [AssertGT] *** Checking Double precision test 1 OK ! *** MESSAGE [AssertLT] *** Checking Double precision test 2 OK ! *** MESSAGE [AssertEQ] *** Checking Double precision test 3 OK ! *** MESSAGE [AssertEQ] *** Checking Double precision test 4 OK ! *** Error [AssertEQ] *** Checking Double precision test 5 FAILURE ! ! check(1,2) = 3.179999999991523E-07 ! is NOT EQUAL to ! 3.179999999998997E-07 < ! answer(1,2) < 3.180000000001004E-07 ! ! 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 module procedure DCTestAssertEqualReal0Digits module procedure DCTestAssertEqualReal1Digits module procedure DCTestAssertEqualReal2Digits module procedure DCTestAssertEqualReal3Digits module procedure DCTestAssertEqualReal4Digits module procedure DCTestAssertEqualReal5Digits module procedure DCTestAssertEqualReal6Digits module procedure DCTestAssertEqualReal7Digits module procedure DCTestAssertEqualDouble0Digits module procedure DCTestAssertEqualDouble1Digits module procedure DCTestAssertEqualDouble2Digits module procedure DCTestAssertEqualDouble3Digits module procedure DCTestAssertEqualDouble4Digits module procedure DCTestAssertEqualDouble5Digits module procedure DCTestAssertEqualDouble6Digits module procedure DCTestAssertEqualDouble7Digits 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 DCTestAssertEqualReal0Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer real, intent(in):: check integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp real:: answer_max real:: answer_min continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if if ( answer < 0.0 .and. check < 0.0 ) then answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) else answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end if wrong = check right_max = answer_max right_min = answer_min if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if err_flag = .not. (answer_max > check .and. check > answer_min) pos_str = '' if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal0Digits subroutine DCTestAssertEqualReal1Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:) real, intent(in):: check(:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) real, allocatable:: answer_max(:) real, allocatable:: answer_min(:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) allocate( answer_max ( & & answer_shape(1) ) & & ) allocate( answer_min ( & & answer_shape(1) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right_max = answer_max ( & & pos(1) ) right_min = answer_min ( & & pos(1) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal1Digits subroutine DCTestAssertEqualReal2Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:) real, intent(in):: check(:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) real, allocatable:: answer_max(:,:) real, allocatable:: answer_min(:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right_max = answer_max ( & & pos(1), & & pos(2) ) right_min = answer_min ( & & pos(1), & & pos(2) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal2Digits subroutine DCTestAssertEqualReal3Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:) real, intent(in):: check(:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) real, allocatable:: answer_max(:,:,:) real, allocatable:: answer_min(:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal3Digits subroutine DCTestAssertEqualReal4Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:) real, intent(in):: check(:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) real, allocatable:: answer_max(:,:,:,:) real, allocatable:: answer_min(:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal4Digits subroutine DCTestAssertEqualReal5Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:) real, intent(in):: check(:,:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) real, allocatable:: answer_max(:,:,:,:,:) real, allocatable:: answer_min(:,:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal5Digits subroutine DCTestAssertEqualReal6Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:,:) real, intent(in):: check(:,:,:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) real, allocatable:: answer_max(:,:,:,:,:,:) real, allocatable:: answer_min(:,:,:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal6Digits subroutine DCTestAssertEqualReal7Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:,:,:) real, intent(in):: check(:,:,:,:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real:: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real:: right_tmp integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) real, allocatable:: answer_max(:,:,:,:,:,:,:) real, allocatable:: answer_min(:,:,:,:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0 & & + 0.1 ** significant_digits ) & & + 0.1 ** (- ignore_digits) answer_min = & & answer & & * ( 1.0 & & - 0.1 ** significant_digits ) & & - 0.1 ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualReal7Digits subroutine DCTestAssertEqualDouble0Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer real(DP), intent(in):: check integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp real(DP):: answer_max real(DP):: answer_min continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if if ( answer < 0.0_DP .and. check < 0.0_DP ) then answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) else answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end if wrong = check right_max = answer_max right_min = answer_min if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if err_flag = .not. (answer_max > check .and. check > answer_min) pos_str = '' if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble0Digits subroutine DCTestAssertEqualDouble1Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:) real(DP), intent(in):: check(:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) real(DP), allocatable:: answer_max(:) real(DP), allocatable:: answer_min(:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) allocate( answer_max ( & & answer_shape(1) ) & & ) allocate( answer_min ( & & answer_shape(1) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right_max = answer_max ( & & pos(1) ) right_min = answer_min ( & & pos(1) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble1Digits subroutine DCTestAssertEqualDouble2Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:) real(DP), intent(in):: check(:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) real(DP), allocatable:: answer_max(:,:) real(DP), allocatable:: answer_min(:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right_max = answer_max ( & & pos(1), & & pos(2) ) right_min = answer_min ( & & pos(1), & & pos(2) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble2Digits subroutine DCTestAssertEqualDouble3Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:) real(DP), intent(in):: check(:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) real(DP), allocatable:: answer_max(:,:,:) real(DP), allocatable:: answer_min(:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble3Digits subroutine DCTestAssertEqualDouble4Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:) real(DP), intent(in):: check(:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) real(DP), allocatable:: answer_max(:,:,:,:) real(DP), allocatable:: answer_min(:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble4Digits subroutine DCTestAssertEqualDouble5Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) real(DP), allocatable:: answer_max(:,:,:,:,:) real(DP), allocatable:: answer_min(:,:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble5Digits subroutine DCTestAssertEqualDouble6Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) real(DP), allocatable:: answer_max(:,:,:,:,:,:) real(DP), allocatable:: answer_min(:,:,:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble6Digits subroutine DCTestAssertEqualDouble7Digits( & & message, answer, check, significant_digits, ignore_digits ) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:,:,:) integer, intent(in):: significant_digits integer, intent(in):: ignore_digits logical:: err_flag character(STRING):: pos_str real(DP):: wrong, right_max, right_min character(STRING):: pos_str_space integer:: pos_str_len real(DP):: right_tmp integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) real(DP), allocatable:: answer_max(:,:,:,:,:,:,:) real(DP), allocatable:: answer_min(:,:,:,:,:,:,:) continue err_flag = .false. if ( significant_digits < 1 ) then write(*,*) ' *** Error [AssertEQ] *** ' write(*,*) ' Specify a number more than 1 to "significant_digits"' call AbortProgram('') end if answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_max ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_min ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative where (both_negative) answer_max = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) elsewhere answer_max = & & answer & & * ( 1.0_DP & & + 0.1_DP ** significant_digits ) & & + 0.1_DP ** (- ignore_digits) answer_min = & & answer & & * ( 1.0_DP & & - 0.1_DP ** significant_digits ) & & - 0.1_DP ** (- ignore_digits) end where judge = answer_max > check .and. check > answer_min judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right_max = answer_max ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right_min = answer_min ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) if ( right_max < right_min ) then right_tmp = right_max right_max = right_min right_min = right_tmp end if write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) deallocate(answer_max, answer_min) if (err_flag) then pos_str_space = '' pos_str_len = len_trim(pos_str) write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT EQUAL to' write(*,*) ' ' // pos_str_space(1:pos_str_len) & & // ' ', right_min, ' < ' write(*,*) ' answer' // trim(pos_str) // ' < ', right_max call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertEqualDouble7Digits subroutine DCTestAssertGreaterThanInt0( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer integer, intent(in):: check logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. err_flag = .not. answer < check abs_mes = '' if ( answer < 0 & & .and. check < 0 & & .and. negative_support_on ) then err_flag = .not. err_flag abs_mes = 'ABSOLUTE value of' end if wrong = check right = answer pos_str = '' if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt0 subroutine DCTestAssertGreaterThanInt1( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:) integer, intent(in):: check(:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right = answer ( & & pos(1) ) write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' if ( both_negative ( & & pos(1) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt1 subroutine DCTestAssertGreaterThanInt2( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:) integer, intent(in):: check(:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right = answer ( & & pos(1), & & pos(2) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' if ( both_negative ( & & pos(1), & & pos(2) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt2 subroutine DCTestAssertGreaterThanInt3( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:) integer, intent(in):: check(:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right = answer ( & & pos(1), & & pos(2), & & pos(3) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt3 subroutine DCTestAssertGreaterThanInt4( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:) integer, intent(in):: check(:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt4 subroutine DCTestAssertGreaterThanInt5( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:,:) integer, intent(in):: check(:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt5 subroutine DCTestAssertGreaterThanInt6( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:,:,:) integer, intent(in):: check(:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt6 subroutine DCTestAssertGreaterThanInt7( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:,:,:,:) integer, intent(in):: check(:,:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanInt7 subroutine DCTestAssertGreaterThanReal0( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer real, intent(in):: check logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. err_flag = .not. answer < check abs_mes = '' if ( answer < 0.0 & & .and. check < 0.0 & & .and. negative_support_on ) then err_flag = .not. err_flag abs_mes = 'ABSOLUTE value of' end if wrong = check right = answer pos_str = '' if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal0 subroutine DCTestAssertGreaterThanReal1( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:) real, intent(in):: check(:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right = answer ( & & pos(1) ) write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' if ( both_negative ( & & pos(1) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal1 subroutine DCTestAssertGreaterThanReal2( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:) real, intent(in):: check(:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right = answer ( & & pos(1), & & pos(2) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' if ( both_negative ( & & pos(1), & & pos(2) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal2 subroutine DCTestAssertGreaterThanReal3( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:) real, intent(in):: check(:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right = answer ( & & pos(1), & & pos(2), & & pos(3) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal3 subroutine DCTestAssertGreaterThanReal4( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:) real, intent(in):: check(:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal4 subroutine DCTestAssertGreaterThanReal5( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:) real, intent(in):: check(:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal5 subroutine DCTestAssertGreaterThanReal6( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:,:) real, intent(in):: check(:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal6 subroutine DCTestAssertGreaterThanReal7( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:,:,:) real, intent(in):: check(:,:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanReal7 subroutine DCTestAssertGreaterThanDouble0( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer real(DP), intent(in):: check logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. err_flag = .not. answer < check abs_mes = '' if ( answer < 0.0_DP & & .and. check < 0.0_DP & & .and. negative_support_on ) then err_flag = .not. err_flag abs_mes = 'ABSOLUTE value of' end if wrong = check right = answer pos_str = '' if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble0 subroutine DCTestAssertGreaterThanDouble1( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:) real(DP), intent(in):: check(:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right = answer ( & & pos(1) ) write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' if ( both_negative ( & & pos(1) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble1 subroutine DCTestAssertGreaterThanDouble2( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:) real(DP), intent(in):: check(:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right = answer ( & & pos(1), & & pos(2) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' if ( both_negative ( & & pos(1), & & pos(2) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble2 subroutine DCTestAssertGreaterThanDouble3( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:) real(DP), intent(in):: check(:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right = answer ( & & pos(1), & & pos(2), & & pos(3) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble3 subroutine DCTestAssertGreaterThanDouble4( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:) real(DP), intent(in):: check(:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble4 subroutine DCTestAssertGreaterThanDouble5( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble5 subroutine DCTestAssertGreaterThanDouble6( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble6 subroutine DCTestAssertGreaterThanDouble7( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer < check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT GREATER THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertGreaterThanDouble7 subroutine DCTestAssertLessThanInt0( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer integer, intent(in):: check logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. err_flag = .not. answer > check abs_mes = '' if ( answer < 0 & & .and. check < 0 & & .and. negative_support_on ) then err_flag = .not. err_flag abs_mes = 'ABSOLUTE value of' end if wrong = check right = answer pos_str = '' if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt0 subroutine DCTestAssertLessThanInt1( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:) integer, intent(in):: check(:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right = answer ( & & pos(1) ) write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' if ( both_negative ( & & pos(1) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt1 subroutine DCTestAssertLessThanInt2( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:) integer, intent(in):: check(:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right = answer ( & & pos(1), & & pos(2) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' if ( both_negative ( & & pos(1), & & pos(2) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt2 subroutine DCTestAssertLessThanInt3( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:) integer, intent(in):: check(:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right = answer ( & & pos(1), & & pos(2), & & pos(3) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt3 subroutine DCTestAssertLessThanInt4( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:) integer, intent(in):: check(:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt4 subroutine DCTestAssertLessThanInt5( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:,:) integer, intent(in):: check(:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt5 subroutine DCTestAssertLessThanInt6( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:,:,:) integer, intent(in):: check(:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt6 subroutine DCTestAssertLessThanInt7( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message integer, intent(in):: answer(:,:,:,:,:,:,:) integer, intent(in):: check(:,:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes integer:: wrong, right integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0 check_negative = check < 0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanInt7 subroutine DCTestAssertLessThanReal0( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer real, intent(in):: check logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. err_flag = .not. answer > check abs_mes = '' if ( answer < 0.0 & & .and. check < 0.0 & & .and. negative_support_on ) then err_flag = .not. err_flag abs_mes = 'ABSOLUTE value of' end if wrong = check right = answer pos_str = '' if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal0 subroutine DCTestAssertLessThanReal1( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:) real, intent(in):: check(:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right = answer ( & & pos(1) ) write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' if ( both_negative ( & & pos(1) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal1 subroutine DCTestAssertLessThanReal2( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:) real, intent(in):: check(:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right = answer ( & & pos(1), & & pos(2) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' if ( both_negative ( & & pos(1), & & pos(2) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal2 subroutine DCTestAssertLessThanReal3( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:) real, intent(in):: check(:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right = answer ( & & pos(1), & & pos(2), & & pos(3) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal3 subroutine DCTestAssertLessThanReal4( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:) real, intent(in):: check(:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal4 subroutine DCTestAssertLessThanReal5( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:) real, intent(in):: check(:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal5 subroutine DCTestAssertLessThanReal6( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:,:) real, intent(in):: check(:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal6 subroutine DCTestAssertLessThanReal7( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real, intent(in):: answer(:,:,:,:,:,:,:) real, intent(in):: check(:,:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real:: wrong, right integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0.0 check_negative = check < 0.0 both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanReal7 subroutine DCTestAssertLessThanDouble0( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer real(DP), intent(in):: check logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. err_flag = .not. answer > check abs_mes = '' if ( answer < 0.0_DP & & .and. check < 0.0_DP & & .and. negative_support_on ) then err_flag = .not. err_flag abs_mes = 'ABSOLUTE value of' end if wrong = check right = answer pos_str = '' if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble0 subroutine DCTestAssertLessThanDouble1( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:) real(DP), intent(in):: check(:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(1), check_shape(1), pos(1) logical:: consist_shape(1) character(TOKEN):: pos_array(1) integer, allocatable:: mask_array(:) logical, allocatable:: judge(:) logical, allocatable:: judge_rev(:) logical, allocatable:: answer_negative(:) logical, allocatable:: check_negative(:) logical, allocatable:: both_negative(:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1) ) & & ) allocate( judge ( & & answer_shape(1) ) & & ) allocate( judge_rev ( & & answer_shape(1) ) & & ) allocate( answer_negative ( & & answer_shape(1) ) & & ) allocate( check_negative ( & & answer_shape(1) ) & & ) allocate( both_negative ( & & answer_shape(1) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1) ) right = answer ( & & pos(1) ) write(unit=pos_array(1), fmt="(i20)") pos(1) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ')' if ( both_negative ( & & pos(1) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble1 subroutine DCTestAssertLessThanDouble2( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:) real(DP), intent(in):: check(:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(2), check_shape(2), pos(2) logical:: consist_shape(2) character(TOKEN):: pos_array(2) integer, allocatable:: mask_array(:,:) logical, allocatable:: judge(:,:) logical, allocatable:: judge_rev(:,:) logical, allocatable:: answer_negative(:,:) logical, allocatable:: check_negative(:,:) logical, allocatable:: both_negative(:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2) ) right = answer ( & & pos(1), & & pos(2) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ')' if ( both_negative ( & & pos(1), & & pos(2) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble2 subroutine DCTestAssertLessThanDouble3( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:) real(DP), intent(in):: check(:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(3), check_shape(3), pos(3) logical:: consist_shape(3) character(TOKEN):: pos_array(3) integer, allocatable:: mask_array(:,:,:) logical, allocatable:: judge(:,:,:) logical, allocatable:: judge_rev(:,:,:) logical, allocatable:: answer_negative(:,:,:) logical, allocatable:: check_negative(:,:,:) logical, allocatable:: both_negative(:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3) ) right = answer ( & & pos(1), & & pos(2), & & pos(3) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble3 subroutine DCTestAssertLessThanDouble4( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:) real(DP), intent(in):: check(:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(4), check_shape(4), pos(4) logical:: consist_shape(4) character(TOKEN):: pos_array(4) integer, allocatable:: mask_array(:,:,:,:) logical, allocatable:: judge(:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:) logical, allocatable:: check_negative(:,:,:,:) logical, allocatable:: both_negative(:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble4 subroutine DCTestAssertLessThanDouble5( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(5), check_shape(5), pos(5) logical:: consist_shape(5) character(TOKEN):: pos_array(5) integer, allocatable:: mask_array(:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble5 subroutine DCTestAssertLessThanDouble6( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(6), check_shape(6), pos(6) logical:: consist_shape(6) character(TOKEN):: pos_array(6) integer, allocatable:: mask_array(:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble6 subroutine DCTestAssertLessThanDouble7( & & message, answer, check, negative_support) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: message real(DP), intent(in):: answer(:,:,:,:,:,:,:) real(DP), intent(in):: check(:,:,:,:,:,:,:) logical, intent(in), optional:: negative_support logical:: err_flag logical:: negative_support_on character(STRING):: pos_str character(TOKEN):: abs_mes real(DP):: wrong, right integer:: answer_shape(7), check_shape(7), pos(7) logical:: consist_shape(7) character(TOKEN):: pos_array(7) integer, allocatable:: mask_array(:,:,:,:,:,:,:) logical, allocatable:: judge(:,:,:,:,:,:,:) logical, allocatable:: judge_rev(:,:,:,:,:,:,:) logical, allocatable:: answer_negative(:,:,:,:,:,:,:) logical, allocatable:: check_negative(:,:,:,:,:,:,:) logical, allocatable:: both_negative(:,:,:,:,:,:,:) continue if (present(negative_support)) then negative_support_on = negative_support else negative_support_on = .true. end if err_flag = .false. answer_shape = shape(answer) check_shape = shape(check) consist_shape = answer_shape == check_shape if (.not. all(consist_shape)) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check is (', check_shape, ')' write(*,*) ' is INCORRECT' write(*,*) ' Correct shape of answer is (', answer_shape, ')' call AbortProgram('') end if allocate( mask_array ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( judge_rev ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( answer_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( check_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) allocate( both_negative ( & & answer_shape(1), & & answer_shape(2), & & answer_shape(3), & & answer_shape(4), & & answer_shape(5), & & answer_shape(6), & & answer_shape(7) ) & & ) answer_negative = answer < 0.0_DP check_negative = check < 0.0_DP both_negative = answer_negative .and. check_negative if (.not. negative_support_on) both_negative = .false. judge = answer > check where (both_negative) judge = .not. judge judge_rev = .not. judge err_flag = any(judge_rev) mask_array = 1 pos = maxloc(mask_array, judge_rev) if (err_flag) then wrong = check ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) right = answer ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) write(unit=pos_array(1), fmt="(i20)") pos(1) write(unit=pos_array(2), fmt="(i20)") pos(2) write(unit=pos_array(3), fmt="(i20)") pos(3) write(unit=pos_array(4), fmt="(i20)") pos(4) write(unit=pos_array(5), fmt="(i20)") pos(5) write(unit=pos_array(6), fmt="(i20)") pos(6) write(unit=pos_array(7), fmt="(i20)") pos(7) pos_str = '(' // & & trim(adjustl(pos_array(1))) // ',' // & & trim(adjustl(pos_array(2))) // ',' // & & trim(adjustl(pos_array(3))) // ',' // & & trim(adjustl(pos_array(4))) // ',' // & & trim(adjustl(pos_array(5))) // ',' // & & trim(adjustl(pos_array(6))) // ',' // & & trim(adjustl(pos_array(7))) // ')' if ( both_negative ( & & pos(1), & & pos(2), & & pos(3), & & pos(4), & & pos(5), & & pos(6), & & pos(7) ) ) then abs_mes = 'ABSOLUTE value of' else abs_mes = '' end if end if deallocate(mask_array, judge, judge_rev) deallocate(answer_negative, check_negative, both_negative) if (err_flag) then write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' ' // trim(abs_mes) // & & ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is NOT LESS THAN' write(*,*) ' ' // trim(abs_mes) // & & ' answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK' end if end subroutine DCTestAssertLessThanDouble7 end module dc_test !-- ! vi:set readonly sw=4 ts=8: ! !Local Variables: !mode: f90 !buffer-read-only: t !End: ! !++