Class | dc_test |
In: |
dc_test.f90
|
Fortran 90/95 におけるテストプログラム作成を補助するための モジュールです.
Compare : | 正答とチェックすべき値とを照合する. |
Compare サブルーチンは以下のように用います. answer に正答を与え, check に照合すべき値を与えます. answer と check には文字型, 整数型, 単精度実数型, 倍精度実数型, 論理型の変数および 配列 (1 〜 7次元) を与えることができます. 2 つの引数の型および次元数は一致している必要があります.
call Compare('Title', answer='foo', check=str1)
もしも answer と check の値, もしくは配列のサイズが異なる場合, テストプログラムはエラーを返して終了します.
具体例は以下の通りです.
use dc_types use dc_test character(STRING):: str1 integer:: int1 real:: numr1(2) real(DP):: numd1(2,3) logical:: y_n str1 = "foo" call Compare('Character', answer='foo', check=str1) int1 = 1 call Compare('Integer', answer=1, check=int1) numr1(:) = (/0.00123, 0.2/) call Compare('Float', answer=(/0.00123, 0.2/), check=numr1) y_n = .true. call Compare('Logical', answer=.true., check=y_n) numd1(1,:) = (/19.432d0, 75.3d0, 3.183d0/) numd1(2,:) = (/0.023d0, 0.9d0, 328.2d0/) call Compare('Double precision 1', & & answer=(/19.432d0, 75.3d0, 3.183d0/), check=numd1(1,:)) call Compare('Double precision 2', & & answer=(/0.023d0, 0.9d0, 238.5d0/), check=numd1(2,:)) end
上記の例では, 最後のテストで敢えて間違った answer を与えているので, 以下のようなメッセージを出力してプログラムは強制終了します.
*** MESSAGE [DCCompare] *** Checking Character OK *** MESSAGE [DCCompare] *** Checking Integer OK *** MESSAGE [DCCompare] *** Checking Float OK *** MESSAGE [DCCompare] *** Checking Logical OK *** MESSAGE [DCCompare] *** Checking Double precision 1 OK *** Error [DCCompare] *** Checking Double precision 2 FAILURE check(3) = 328.2 is INCORRECT Correct answer is answer(3) = 238.5
Subroutine : | |
item : | character(*), intent(in) |
answer : | character(*), intent(in) |
check : | character(*), intent(in) |
subroutine DCCompareChar0(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar0
Subroutine : | |
item : | character(*), intent(in) |
answer : | integer, intent(in) |
check : | integer, intent(in) |
subroutine DCCompareInt0(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt0
Subroutine : | |
item : | character(*), intent(in) |
answer : | logical, intent(in) |
check : | logical, intent(in) |
subroutine DCCompareLogical0(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar0(item, answer_str, check_str) end subroutine DCCompareLogical0
Subroutine : | |
item : | character(*), intent(in) |
answer : | real(DP), intent(in) |
check : | real(DP), intent(in) |
subroutine DCCompareDouble0(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble0
Subroutine : | |
item : | character(*), intent(in) |
answer : | real, intent(in) |
check : | real, intent(in) |
subroutine DCCompareReal0(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal0
Subroutine : | |
item : | character(*), intent(in) |
answer(:) : | character(*), intent(in) |
check(:) : | character(*), intent(in) |
subroutine DCCompareChar1(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar1
Subroutine : | |
item : | character(*), intent(in) |
answer(:) : | integer, intent(in) |
check(:) : | integer, intent(in) |
subroutine DCCompareInt1(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt1
Subroutine : | |
item : | character(*), intent(in) |
answer(:) : | logical, intent(in) |
check(:) : | logical, intent(in) |
subroutine DCCompareLogical1(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar1(item, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCCompareLogical1
Subroutine : | |
item : | character(*), intent(in) |
answer(:) : | real(DP), intent(in) |
check(:) : | real(DP), intent(in) |
subroutine DCCompareDouble1(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble1
Subroutine : | |
item : | character(*), intent(in) |
answer(:) : | real, intent(in) |
check(:) : | real, intent(in) |
subroutine DCCompareReal1(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal1
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:) : | character(*), intent(in) |
check(:,:) : | character(*), intent(in) |
subroutine DCCompareChar2(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar2
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:) : | integer, intent(in) |
check(:,:) : | integer, intent(in) |
subroutine DCCompareInt2(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt2
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:) : | logical, intent(in) |
check(:,:) : | logical, intent(in) |
subroutine DCCompareLogical2(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar2(item, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCCompareLogical2
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:) : | real(DP), intent(in) |
check(:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble2(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble2
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:) : | real, intent(in) |
check(:,:) : | real, intent(in) |
subroutine DCCompareReal2(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal2
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:) : | character(*), intent(in) |
check(:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar3(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar3
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:) : | integer, intent(in) |
check(:,:,:) : | integer, intent(in) |
subroutine DCCompareInt3(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt3
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:) : | logical, intent(in) |
check(:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical3(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar3(item, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCCompareLogical3
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:) : | real(DP), intent(in) |
check(:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble3(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble3
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:) : | real, intent(in) |
check(:,:,:) : | real, intent(in) |
subroutine DCCompareReal3(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal3
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar4(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar4
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:) : | integer, intent(in) |
check(:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt4(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt4
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:) : | logical, intent(in) |
check(:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical4(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar4(item, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCCompareLogical4
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble4(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble4
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:) : | real, intent(in) |
check(:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal4(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal4
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar5(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar5
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:) : | integer, intent(in) |
check(:,:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt5(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt5
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:) : | logical, intent(in) |
check(:,:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical5(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar5(item, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCCompareLogical5
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble5(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble5
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:) : | real, intent(in) |
check(:,:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal5(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal5
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar6(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar6
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | integer, intent(in) |
check(:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt6(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt6
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | logical, intent(in) |
check(:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical6(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar6(item, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCCompareLogical6
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble6(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble6
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:) : | real, intent(in) |
check(:,:,:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal6(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal6
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | character(*), intent(in) |
check(:,:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar7(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareChar7
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | integer, intent(in) |
check(:,:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt7(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareInt7
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | logical, intent(in) |
check(:,:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical7(item, answer, check) use dc_types, only: STRING implicit none character(*), intent(in):: item 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 DCCompareChar7(item, answer_str, check_str) deallocate(answer_str, answer_tmp, answer_str_tmp) deallocate(check_str, check_tmp, check_str_tmp) end subroutine DCCompareLogical7
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble7(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareDouble7
Subroutine : | |
item : | character(*), intent(in) |
answer(:,:,:,:,:,:,:) : | real, intent(in) |
check(:,:,:,:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal7(item, answer, check) use sysdep, only: AbortProgram use dc_types, only: STRING, TOKEN implicit none character(*), intent(in):: item 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 [DCCompare] *** Checking ' // trim(item) // ' FAILURE' write(*,*) '' write(*,*) ' shape of check 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK' end if end subroutine DCCompareReal7