!-- ! *** Caution!! *** ! ! This file is generated from "dc_test.rb2f90" by Ruby 1.8.2. ! Please do not edit this file directly. ! ! [JAPANESE] ! ! ※※※ 注意!!! ※※※ ! ! このファイルは "dc_test.rb2f90" から Ruby 1.8.2 ! によって自動生成されたファイルです. ! このファイルを直接編集しませんようお願い致します. ! ! !++ ! !== Test module ! ! Authors:: Yasuhiro MORIKAWA ! Version:: $Id: dc_test.f90,v 1.7 2006/07/19 08:17:56 morikawa Exp $ ! Tag Name:: $Name: gt4f90io-20061118 $ ! Copyright:: Copyright (C) GFD Dennou Club, 2005. All rights reserved. ! License:: See COPYRIGHT[link:../../COPYRIGHT] ! ! This file provides dc_test ! module dc_test ! !== Overview ! ! Fortran 90/95 におけるテストプログラム作成を補助するための ! モジュールです. ! !== List ! ! Compare :: 正答とチェックすべき値とを照合する. ! !== Usage ! ! 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 ! ! use dc_types, only : STRING, DP implicit none private public Compare interface Compare module procedure DCCompareChar0 module procedure DCCompareChar1 module procedure DCCompareChar2 module procedure DCCompareChar3 module procedure DCCompareChar4 module procedure DCCompareChar5 module procedure DCCompareChar6 module procedure DCCompareChar7 module procedure DCCompareInt0 module procedure DCCompareInt1 module procedure DCCompareInt2 module procedure DCCompareInt3 module procedure DCCompareInt4 module procedure DCCompareInt5 module procedure DCCompareInt6 module procedure DCCompareInt7 module procedure DCCompareReal0 module procedure DCCompareReal1 module procedure DCCompareReal2 module procedure DCCompareReal3 module procedure DCCompareReal4 module procedure DCCompareReal5 module procedure DCCompareReal6 module procedure DCCompareReal7 module procedure DCCompareDouble0 module procedure DCCompareDouble1 module procedure DCCompareDouble2 module procedure DCCompareDouble3 module procedure DCCompareDouble4 module procedure DCCompareDouble5 module procedure DCCompareDouble6 module procedure DCCompareDouble7 module procedure DCCompareLogical0 module procedure DCCompareLogical1 module procedure DCCompareLogical2 module procedure DCCompareLogical3 module procedure DCCompareLogical4 module procedure DCCompareLogical5 module procedure DCCompareLogical6 module procedure DCCompareLogical7 end interface contains 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 end module dc_test !-- ! vi:set readonly sw=4 ts=8: ! !Local Variables: !mode: f90 !buffer-read-only: t !End: ! !++