Class | dc_test |
In: |
dc_test.f90
|
Fortran 90/95 におけるテストプログラム作成を補助するための モジュールです.
オブジェクト指向スクリプト言語 Ruby の Test::Unit クラス の機能の一部を模倣しています.
AssertEqual : | 正答とチェックすべき値とを照合する. |
AssertEqual サブルーチンは以下のように用います. message にはテストプログラムを実行した際に表示する 任意の長さの文字列を与えます. そして, answer には正答を, check には照合すべき値を与えます. answer と check にはそれぞれ文字型, 整数型, 単精度実数型, 倍精度実数型, 論理型の変数および 配列 (1 〜 7次元) を与えることができます. 2 つの引数の型および次元数は一致している必要があります.
program test use dc_test, only: AssertEqual implicit none character(32) :: str1 str1 = 'foo' call AssertEqual(message='String test', answer='foo', check=str1) end program test
もしも answer と check の値, もしくは配列のサイズが異なる場合, テストプログラムはエラーを返して終了します.
具体例は以下の通りです.
program test_sample use dc_types, only: STRING, DP use dc_test, only: AssertEqual character(STRING):: str1 integer:: int1 real:: numr1(2) real(DP):: numd1(2,3) logical:: y_n str1 = "foo" call AssertEqual('Character test', answer='foo', check=str1) int1 = 1 call AssertEqual('Integer test', answer=1, check=int1) numr1(:) = (/0.00123, 0.2/) call AssertEqual('Float test', answer=(/0.00123, 0.2/), check=numr1) y_n = .true. call AssertEqual('Logical test', answer=.true., check=y_n) numd1(1,:) = (/19.432d0, 75.3d0, 3.183d0/) numd1(2,:) = (/0.023d0, 0.9d0, 328.2d0/) call AssertEqual('Double precision test 1', & & answer=(/19.432d0, 75.3d0, 3.183d0/), check=numd1(1,:)) call AssertEqual('Double precision test 2', & & answer=(/0.023d0, 0.9d0, 238.5d0/), check=numd1(2,:)) end program test_sample
上記の例では, 最後のテストで敢えて間違った answer を与えているので, 以下のようなメッセージを出力してプログラムは強制終了します.
*** MESSAGE [DCAssertEqual] *** Checking Character test OK *** MESSAGE [DCAssertEqual] *** Checking Integer test OK *** MESSAGE [DCAssertEqual] *** Checking Float test OK *** MESSAGE [DCAssertEqual] *** Checking Logical test OK *** MESSAGE [DCAssertEqual] *** Checking Double precision test 1 OK *** Error [DCAssertEqual] *** Checking Double precision test 2 FAILURE check(3) = 328.2 is INCORRECT Correct answer is answer(3) = 238.5
Subroutine : | |
message : | character(*), intent(in) |
answer : | character(*), intent(in) |
check : | character(*), intent(in) |
subroutine DCAssertEqualChar0(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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar0
Subroutine : | |
message : | character(*), intent(in) |
answer : | integer, intent(in) |
check : | integer, intent(in) |
subroutine DCAssertEqualInt0(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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt0
Subroutine : | |
message : | character(*), intent(in) |
answer : | logical, intent(in) |
check : | logical, intent(in) |
subroutine DCAssertEqualLogical0(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 DCAssertEqualChar0(message, answer_str, check_str) end subroutine DCAssertEqualLogical0
Subroutine : | |
message : | character(*), intent(in) |
answer : | real(DP), intent(in) |
check : | real(DP), intent(in) |
subroutine DCAssertEqualDouble0(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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble0
Subroutine : | |
message : | character(*), intent(in) |
answer : | real, intent(in) |
check : | real, intent(in) |
subroutine DCAssertEqualReal0(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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal0
Subroutine : | |
message : | character(*), intent(in) |
answer(:) : | character(*), intent(in) |
check(:) : | character(*), intent(in) |
subroutine DCAssertEqualChar1(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar1
Subroutine : | |
message : | character(*), intent(in) |
answer(:) : | integer, intent(in) |
check(:) : | integer, intent(in) |
subroutine DCAssertEqualInt1(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt1
Subroutine : | |
message : | character(*), intent(in) |
answer(:) : | logical, intent(in) |
check(:) : | logical, intent(in) |
subroutine DCAssertEqualLogical1(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 DCAssertEqualChar1(message, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCAssertEqualLogical1
Subroutine : | |
message : | character(*), intent(in) |
answer(:) : | real(DP), intent(in) |
check(:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble1(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble1
Subroutine : | |
message : | character(*), intent(in) |
answer(:) : | real, intent(in) |
check(:) : | real, intent(in) |
subroutine DCAssertEqualReal1(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal1
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:) : | character(*), intent(in) |
check(:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar2(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar2
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:) : | integer, intent(in) |
check(:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt2(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt2
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:) : | logical, intent(in) |
check(:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical2(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 DCAssertEqualChar2(message, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCAssertEqualLogical2
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:) : | real(DP), intent(in) |
check(:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble2(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble2
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:) : | real, intent(in) |
check(:,:) : | real, intent(in) |
subroutine DCAssertEqualReal2(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal2
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:) : | character(*), intent(in) |
check(:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar3(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar3
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:) : | integer, intent(in) |
check(:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt3(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt3
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:) : | logical, intent(in) |
check(:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical3(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 DCAssertEqualChar3(message, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCAssertEqualLogical3
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:) : | real(DP), intent(in) |
check(:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble3(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble3
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:) : | real, intent(in) |
check(:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal3(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal3
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar4(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar4
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:) : | integer, intent(in) |
check(:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt4(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt4
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:) : | logical, intent(in) |
check(:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical4(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 DCAssertEqualChar4(message, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCAssertEqualLogical4
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble4(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble4
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:) : | real, intent(in) |
check(:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal4(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal4
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar5(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar5
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:) : | integer, intent(in) |
check(:,:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt5(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt5
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:) : | logical, intent(in) |
check(:,:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical5(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 DCAssertEqualChar5(message, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCAssertEqualLogical5
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble5(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble5
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:) : | real, intent(in) |
check(:,:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal5(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal5
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar6(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar6
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | integer, intent(in) |
check(:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt6(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt6
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | logical, intent(in) |
check(:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical6(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 DCAssertEqualChar6(message, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCAssertEqualLogical6
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble6(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble6
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | real, intent(in) |
check(:,:,:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal6(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal6
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar7(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong) write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right) call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualChar7
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | integer, intent(in) |
check(:,:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt7(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualInt7
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | logical, intent(in) |
check(:,:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical7(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 DCAssertEqualChar7(message, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCAssertEqualLogical7
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble7(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualDouble7
Subroutine : | |
message : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | real, intent(in) |
check(:,:,:,:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal7(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 [DCAssertEqual] *** 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 [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE' write(*,*) '' write(*,*) ' check' // trim(pos_str) // ' = ', wrong write(*,*) ' is INCORRECT' write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right call AbortProgram('') else write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK' end if end subroutine DCAssertEqualReal7