dc_test.f90
Go to the documentation of this file.
1 !--
2 ! *** Caution!! ***
3 !
4 ! This file is generated from "dc_test.rb2f90" by Ruby 2.3.3.
5 ! Please do not edit this file directly.
6 !
7 ! [JAPANESE]
8 !
9 ! ※※※ 注意!!! ※※※
10 !
11 ! このファイルは "dc_test.rb2f90" から Ruby 2.3.3
12 ! によって自動生成されたファイルです.
13 ! このファイルを直接編集しませんようお願い致します.
14 !
15 !
16 !++
17 !
18 != テストプログラム作成支援
19 !
20 != Support making test programs
21 !
22 ! Authors:: Yasuhiro MORIKAWA
23 ! Version:: $Id: dc_test.rb2f90,v 1.2 2009-03-22 02:17:34 morikawa Exp $
24 ! Tag Name:: $Name: $
25 ! Copyright:: Copyright (C) GFD Dennou Club, 2005-2007. All rights reserved.
26 ! License:: See COPYRIGHT[link:../../COPYRIGHT]
27 !
28 
29 module dc_test
30  !
31  != テストプログラム作成支援
32  !
33  != Support making test programs
34  !
35  ! <b>Note that Japanese and English are described in parallel.</b>
36  !
37  ! Fortran 90/95 におけるテストプログラム作成を補助するための
38  ! モジュールです.
39  !
40  ! {オブジェクト指向スクリプト言語 Ruby}[http://www.ruby-lang.org/]
41  ! の {Test::Unit クラス}[http://www.ruby-lang.org/ja/man/?cmd=view;name=Test%3A%3AUnit]
42  ! の機能の一部を模倣しています.
43  !
44  ! This module supports making Fortran 90/95 test programs.
45  !
46  ! A part of {Test::Unit class}[http://www.ruby-lang.org/ja/man/?cmd=view;name=Test%3A%3AUnit]
47  ! in {Object-oriented programming language Ruby}[http://www.ruby-lang.org/]
48  ! is imitated.
49  !
50  !== Procedures List
51  !
52  ! AssertEqual :: 正答とチェックすべき値が等しいことをチェックする.
53  ! AssertGreaterThan :: ある値よりもチェックすべき値が大きいことをチェックする.
54  ! AssertLessThan :: ある値よりもチェックすべき値が小さいことをチェックする.
55  ! ------------ :: ------------
56  ! AssertEqual :: It is verified that a examined value is equal to
57  ! a right answer.
58  ! AssertGreaterThan :: It is verified that examined value is greater than
59  ! a certain value.
60  ! AssertLessThan :: It is verified that examined value is less than
61  ! a certain value.
62  !
63  !== Usage
64  !
65  ! AssertEqual サブルーチンの使用例として, 以下に簡単な
66  ! テストプログラムを記します.
67  ! *message* にはテストプログラムを実行した際に表示する
68  ! 任意の長さの文字列を与えます.
69  ! そして, *answer* には正答を, *check* には照合すべき値を与えます.
70  ! *answer* と *check* にはそれぞれ文字型, 整数型, 単精度実数型,
71  ! 倍精度実数型, 論理型の変数および
72  ! 配列 (1 〜 7次元) を与えることができます.
73  ! 2 つの引数の型および次元数は一致している必要があります.
74  !
75  ! A simple test program is showed as an example of how "AssertEqual"
76  ! subroutine is used as follows.
77  ! Give arbitrary length string to *message*. This string is displayed
78  ! when the test program is execute.
79  ! And give the right answer to *answer*, examined value to *check*.
80  ! Character, integer, simple precision real, double precision real,
81  ! logical variables and arrays (rank 1 - 7) are allowed to
82  ! give to *answer* and *check*.
83  ! The types of *answer* and *check* must be same.
84  !
85  !
86  ! program test
87  ! use dc_test, only: AssertEqual
88  ! implicit none
89  ! character(32):: str1
90  ! real:: r1(2)
91  !
92  ! str1 = 'foo'
93  ! r1 = (/ 1.0, 2.0 /)
94  ! call AssertEqual(message='String test', answer='foo', check=str1)
95  ! call AssertEqual(message='Float test', &
96  ! & answer=(/1.0, 2.0/), check=r1)
97  ! end program test
98  !
99  !
100  ! *check* と *answer* との値, および配列のサイズが一致する場合に
101  ! テストプログラムは「Checking <i><*message* に与えられた文字></i> OK」
102  ! というメッセージを表示します. プログラムは続行します.
103  ! AssertEqual の代わりに AssertGreaterThan を使用する場合には
104  ! *check* が *answer* よりも大きい場合,
105  ! AssertLessThan を使用する場合には *check* が *answer* よりも小さい場合に
106  ! プログラムは続行します.
107  !
108  ! 一方で *answer* と *check* の値, もしくは配列のサイズが異なる場合には,
109  ! テストプログラムは「Checking <i><*message* に与えられた文字></i> FAILURE」
110  ! というメッセージを表示します. プログラムはエラーを発生させて終了します.
111  ! AssertEqual の代わりに AssertGreaterThan を使用する場合には
112  ! *check* が *answer* よりも大きくない場合,
113  ! AssertLessThan を使用する場合には *check* が *answer* よりも
114  ! 小さくない場合にプログラムは終了します.
115  !
116  !
117  ! When the values and array sizes of *check* and *answer* are same,
118  ! the test program displays a message
119  ! "Checking <i><string given to *message*></i> OK", and the program
120  ! continues. Using "AssertGreaterThan" instead of "AssertEqual",
121  ! the program continues when *check* is greater than *answer*.
122  ! Using "AssertLessThan",
123  ! the program continues when *check* is less than *answer*.
124  !
125  ! On the other hand, when the values or array sizes of *check* and
126  ! *answer* are different, the test program displays a message
127  ! "Checking <i><string given to *message*></i> FAILURE", and the
128  ! program aborts. Using "AssertGreaterThan" instead of "AssertEqual",
129  ! the program aborts when *check* is not greater than *answer*.
130  ! Using "AssertLessThan",
131  ! the program aborts when *check* is not less than *answer*.
132  !
133  !
134  !=== 精度の指定
135  !=== Specification of accuracy
136  !
137  ! 単精度実数型, 倍精度実数型同士の比較において,
138  ! 丸め誤差や情報落ち誤差を考慮したい場合には,
139  ! 引数 *significant_digits*, *ignore_digits* に整数型を与えてください.
140  ! *significant_digits* には有効数字の桁数を, *ignore_digits* には
141  ! 無視するオーダーを与えます. 以下の例では, 有効数字の桁数を 7 とし,
142  ! 1.0e-6 以下の数値を無視して値の比較を行っています.
143  !
144  ! About comparison of single precision reals or double precision reals,
145  ! in order to consider rounding errors and information loss errors,
146  ! specify integer to *significant_digits*, *ignore_digits* arguments.
147  ! Specify significant digits to *significant_digits*, and
148  ! negligible order to *ignore_digits*.
149  ! In the following example, significant digits is 7, and
150  ! numerical value less than 1.0e-6 is ignored.
151  !
152  ! program test2
153  ! use dc_test, only: AssertEqual
154  ! implicit none
155  ! real:: numd1(2,3)
156  !
157  ! numd1 = reshape((/-19.432, 75.3, 3.183, &
158  ! & 0.023, -0.9, 328.2/), &
159  ! & (/2,3/))
160  !
161  ! call AssertEqual( 'Float (single precision) test', &
162  ! & answer = numd1, &
163  ! & check = ( numd1 / 3.0 ) * 3.0, &
164  ! & significant_digits = 7, ignore_digits = -6 )
165  !
166  ! end program test2
167  !
168  !
169  !=== 負の値の取り扱い
170  !=== Treatment of negative values
171  !
172  ! 比較される *answer* の値と *check* の値が両方とも負の場合,
173  ! AssertGreaterThan および AssertLessThan は 2 つの値の絶対値の
174  ! 比較を行います. エラーメッセージは以下のようになります.
175  ! オプショナル引数 *negative_support* に .false. を与える場合,
176  ! 絶対値での比較を行いません.
177  !
178  ! "AssertGreaterThan" and "AssertLessThan" compare absolute values
179  ! of *answer* and *check* when both compared two values are negative.
180  ! In this case, error message is as follows.
181  ! When an optional argument *negative_support* is .false.,
182  ! the comparison with absolute values is not done.
183  !
184  ! ABSOLUTE value of check(14,1) = -1.189774221E-09
185  ! is NOT LESS THAN
186  ! ABSOLUTE value of answer(14,1) = -1.189774405E-09
187  !
188  !
189  !=== 使用例
190  !=== Example
191  !
192  ! 使用例は以下の通りです.
193  !
194  ! Example of use is showed as follows.
195  !
196  !
197  ! program test_sample
198  ! use dc_types, only: STRING, DP
199  ! use dc_test, only: AssertEqual, AssertGreaterThan, AssertLessThan
200  ! implicit none
201  ! character(STRING):: str1, str2
202  ! real:: r1(2)
203  ! integer:: int1
204  ! real:: numr1(2)
205  ! real(DP):: numd1(2,3), numd2(2,3)
206  ! logical:: y_n
207  ! continue
208  !
209  ! str1 = 'foo'
210  ! r1 = (/ 1.0_DP, 2.0_DP /)
211  ! call AssertEqual( message = 'String test', answer = 'foo', check = str1 )
212  ! call AssertEqual( message = 'Float test', &
213  ! & answer = (/1.0e0, 2.0e0/), check = r1 )
214  !
215  ! str2 = "foo"
216  ! call AssertEqual( 'Character test', answer = 'foo', check = str2 )
217  ! int1 = 1
218  ! call AssertEqual( 'Integer test', answer = 1, check = int1 )
219  ! numr1(:) = (/ 0.001235423, 0.248271 /)
220  ! call AssertGreaterThan( 'Float test 1', &
221  ! & answer = (/ 0.00061771142, 0.1241354 /), check = numr1 / 2.0 )
222  ! call AssertLessThan( 'Float test 2', &
223  ! & answer = (/ 0.00061771158, 0.1241358 /), check = numr1 / 2.0 )
224  ! y_n = .true.
225  ! call AssertEqual( 'Logical test', answer = .true., check = y_n )
226  !
227  ! numd1 = reshape( (/ -19.432_DP, 75.3_DP, 3.183_DP, &
228  ! & 0.023_DP, -0.9_DP, 328.2_DP /), &
229  ! & (/ 2,3 /) )
230  ! call AssertGreaterThan( 'Double precision test 1', &
231  ! & answer = reshape( (/ -38.8639_DP, 150.5999_DP, 6.365999_DP, &
232  ! & 0.0459999_DP, -1.7999_DP, 656.3999_DP /), &
233  ! & (/ 2,3 /) ), &
234  ! & check = numd1*2.0_DP )
235  ! call AssertLessThan( 'Double precision test 2', &
236  ! & answer = reshape( (/ -38.86401_DP, 150.60001_DP, 6.3660001_DP, &
237  ! & 0.04600001_DP, -1.8000001_DP, 656.6_DP /), &
238  ! & (/ 2,3 /) ), &
239  ! & check = numd1*2.0_DP, negative_support=.true. )
240  !
241  ! call AssertEqual( 'Double precision test 3', &
242  ! & answer = numd1, &
243  ! & check = ( numd1 / 3.0_DP ) * 3.0_DP, &
244  ! & significant_digits = 10, ignore_digits = -10 )
245  !
246  ! numd2 = reshape( (/ 19.4e+7_DP, 75.3_DP, 3.18e-7_DP, &
247  ! & 0.023e-7_DP, 0.9e+7_DP, 328.2_DP /), &
248  ! & (/ 2,3 /) )
249  !
250  ! call AssertEqual( 'Double precision test 4', &
251  ! & answer = numd2, &
252  ! & check = ( ( ( numd2 + 0.008_DP - 0.008_DP ) / 1.5_DP ) * 3.0_DP ) / 2.0_DP, &
253  ! & significant_digits = 10, ignore_digits = -15 )
254  !
255  ! call AssertEqual( 'Double precision test 5', &
256  ! & answer = numd2, &
257  ! & check = ( ( ( numd2 + 0.008_DP - 0.008_DP ) / 1.5_DP ) * 3.0_DP ) / 2.0_DP, &
258  ! & significant_digits = 15, ignore_digits = -19 )
259  !
260  ! end program test_sample
261  !
262  !
263  ! 上記の例では, 最後のテストで敢えて小さすぎる値を無視するオーダー
264  ! として設定しているため, 以下のようなメッセージを出力して
265  ! プログラムは強制終了します.
266  !
267  ! In above example, too small negligible order is specified on purpose
268  ! in the last test. Then the program displays a following message,
269  ! and aborts.
270  !
271  ! *** MESSAGE [AssertEQ] *** Checking String test OK
272  ! *** MESSAGE [AssertEQ] *** Checking Float test OK
273  ! *** MESSAGE [AssertEQ] *** Checking Character test OK
274  ! *** MESSAGE [AssertEQ] *** Checking Integer test OK
275  ! *** MESSAGE [AssertGT] *** Checking Float test 1 OK
276  ! *** MESSAGE [AssertLT] *** Checking Float test 2 OK
277  ! *** MESSAGE [AssertEQ] *** Checking Logical test OK
278  ! *** MESSAGE [AssertGT] *** Checking Double precision test 1 OK
279  ! *** MESSAGE [AssertLT] *** Checking Double precision test 2 OK
280  ! *** MESSAGE [AssertEQ] *** Checking Double precision test 3 OK
281  ! *** MESSAGE [AssertEQ] *** Checking Double precision test 4 OK
282  ! *** Error [AssertEQ] *** Checking Double precision test 5 FAILURE
283  !
284  ! check(1,2) = 3.179999999991523E-07
285  ! is NOT EQUAL to
286  ! 3.179999999998997E-07 <
287  ! answer(1,2) < 3.180000000001004E-07
288  !
289  !
290  use dc_types, only : string, dp
291  implicit none
292  private
293  public assertequal, assertgreaterthan, assertlessthan
294 
295  interface assertequal
296  module procedure dctestassertequalchar0
297 
298  module procedure dctestassertequalchar1
299 
300  module procedure dctestassertequalchar2
301 
302  module procedure dctestassertequalchar3
303 
304  module procedure dctestassertequalchar4
305 
306  module procedure dctestassertequalchar5
307 
308  module procedure dctestassertequalchar6
309 
310  module procedure dctestassertequalchar7
311 
312 
313  module procedure dctestassertequalint0
314 
315  module procedure dctestassertequalint1
316 
317  module procedure dctestassertequalint2
318 
319  module procedure dctestassertequalint3
320 
321  module procedure dctestassertequalint4
322 
323  module procedure dctestassertequalint5
324 
325  module procedure dctestassertequalint6
326 
327  module procedure dctestassertequalint7
328 
329 
330  module procedure dctestassertequalreal0
331 
332  module procedure dctestassertequalreal1
333 
334  module procedure dctestassertequalreal2
335 
336  module procedure dctestassertequalreal3
337 
338  module procedure dctestassertequalreal4
339 
340  module procedure dctestassertequalreal5
341 
342  module procedure dctestassertequalreal6
343 
344  module procedure dctestassertequalreal7
345 
346 
347  module procedure dctestassertequaldouble0
348 
349  module procedure dctestassertequaldouble1
350 
351  module procedure dctestassertequaldouble2
352 
353  module procedure dctestassertequaldouble3
354 
355  module procedure dctestassertequaldouble4
356 
357  module procedure dctestassertequaldouble5
358 
359  module procedure dctestassertequaldouble6
360 
361  module procedure dctestassertequaldouble7
362 
363 
364 
365  module procedure dctestassertequallogical0
366 
367  module procedure dctestassertequallogical1
368 
369  module procedure dctestassertequallogical2
370 
371  module procedure dctestassertequallogical3
372 
373  module procedure dctestassertequallogical4
374 
375  module procedure dctestassertequallogical5
376 
377  module procedure dctestassertequallogical6
378 
379  module procedure dctestassertequallogical7
380 
381 
382  module procedure dctestassertequalreal0digits
383 
384  module procedure dctestassertequalreal1digits
385 
386  module procedure dctestassertequalreal2digits
387 
388  module procedure dctestassertequalreal3digits
389 
390  module procedure dctestassertequalreal4digits
391 
392  module procedure dctestassertequalreal5digits
393 
394  module procedure dctestassertequalreal6digits
395 
396  module procedure dctestassertequalreal7digits
397 
398 
399  module procedure dctestassertequaldouble0digits
400 
401  module procedure dctestassertequaldouble1digits
402 
403  module procedure dctestassertequaldouble2digits
404 
405  module procedure dctestassertequaldouble3digits
406 
407  module procedure dctestassertequaldouble4digits
408 
409  module procedure dctestassertequaldouble5digits
410 
411  module procedure dctestassertequaldouble6digits
412 
413  module procedure dctestassertequaldouble7digits
414 
415 
416 
417  end interface
418 
419  interface assertgreaterthan
420  module procedure dctestassertgreaterthanint0
421 
422  module procedure dctestassertgreaterthanint1
423 
424  module procedure dctestassertgreaterthanint2
425 
426  module procedure dctestassertgreaterthanint3
427 
428  module procedure dctestassertgreaterthanint4
429 
430  module procedure dctestassertgreaterthanint5
431 
432  module procedure dctestassertgreaterthanint6
433 
434  module procedure dctestassertgreaterthanint7
435 
436 
437  module procedure dctestassertgreaterthanreal0
438 
439  module procedure dctestassertgreaterthanreal1
440 
441  module procedure dctestassertgreaterthanreal2
442 
443  module procedure dctestassertgreaterthanreal3
444 
445  module procedure dctestassertgreaterthanreal4
446 
447  module procedure dctestassertgreaterthanreal5
448 
449  module procedure dctestassertgreaterthanreal6
450 
451  module procedure dctestassertgreaterthanreal7
452 
453 
454  module procedure dctestassertgreaterthandouble0
455 
456  module procedure dctestassertgreaterthandouble1
457 
458  module procedure dctestassertgreaterthandouble2
459 
460  module procedure dctestassertgreaterthandouble3
461 
462  module procedure dctestassertgreaterthandouble4
463 
464  module procedure dctestassertgreaterthandouble5
465 
466  module procedure dctestassertgreaterthandouble6
467 
468  module procedure dctestassertgreaterthandouble7
469 
470 
471  end interface
472 
473  interface assertlessthan
474  module procedure dctestassertlessthanint0
475 
476  module procedure dctestassertlessthanint1
477 
478  module procedure dctestassertlessthanint2
479 
480  module procedure dctestassertlessthanint3
481 
482  module procedure dctestassertlessthanint4
483 
484  module procedure dctestassertlessthanint5
485 
486  module procedure dctestassertlessthanint6
487 
488  module procedure dctestassertlessthanint7
489 
490 
491  module procedure dctestassertlessthanreal0
492 
493  module procedure dctestassertlessthanreal1
494 
495  module procedure dctestassertlessthanreal2
496 
497  module procedure dctestassertlessthanreal3
498 
499  module procedure dctestassertlessthanreal4
500 
501  module procedure dctestassertlessthanreal5
502 
503  module procedure dctestassertlessthanreal6
504 
505  module procedure dctestassertlessthanreal7
506 
507 
508  module procedure dctestassertlessthandouble0
509 
510  module procedure dctestassertlessthandouble1
511 
512  module procedure dctestassertlessthandouble2
513 
514  module procedure dctestassertlessthandouble3
515 
516  module procedure dctestassertlessthandouble4
517 
518  module procedure dctestassertlessthandouble5
519 
520  module procedure dctestassertlessthandouble6
521 
522  module procedure dctestassertlessthandouble7
523 
524 
525  end interface
526 
527 contains
528 
529 
530  subroutine dctestassertequalchar0(message, answer, check)
531  use sysdep, only: abortprogram
532  use dc_types, only: string, token
533  implicit none
534  character(*), intent(in):: message
535  character(*), intent(in):: answer
536  character(*), intent(in):: check
537  logical:: err_flag
538  character(STRING):: pos_str
539  character(STRING):: wrong, right
540 
541 
542 
543 
544 
545 
546  continue
547  err_flag = .false.
548 
549 
550  err_flag = .not. trim(answer) == trim(check)
551  wrong = check
552  right = answer
553  pos_str = ''
554 
555 
556 
557 
558  if (err_flag) then
559  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
560  write(*,*) ''
561  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
562  write(*,*) ' is NOT EQUAL to'
563  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
564 
565  call abortprogram('')
566  else
567  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
568  end if
569 
570 
571  end subroutine dctestassertequalchar0
572 
573 
574  subroutine dctestassertequalchar1(message, answer, check)
575  use sysdep, only: abortprogram
576  use dc_types, only: string, token
577  implicit none
578  character(*), intent(in):: message
579  character(*), intent(in):: answer(:)
580  character(*), intent(in):: check(:)
581  logical:: err_flag
582  character(STRING):: pos_str
583  character(STRING):: wrong, right
584 
585  integer:: answer_shape(1), check_shape(1), pos(1)
586  logical:: consist_shape(1)
587  character(TOKEN):: pos_array(1)
588  integer, allocatable:: mask_array(:)
589  logical, allocatable:: judge(:)
590  logical, allocatable:: judge_rev(:)
591 
592 
593  character(STRING), allocatable:: answer_fixed_length(:)
594  character(STRING), allocatable:: check_fixed_length(:)
595 
596 
597 
598  continue
599  err_flag = .false.
600 
601 
602  answer_shape = shape(answer)
603  check_shape = shape(check)
604 
605  consist_shape = answer_shape == check_shape
606 
607  if (.not. all(consist_shape)) then
608  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
609  write(*,*) ''
610  write(*,*) ' shape of check is (', check_shape, ')'
611  write(*,*) ' is INCORRECT'
612  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
613 
614  call abortprogram('')
615  end if
616 
617 
618  allocate( mask_array( &
619 
620  & answer_shape(1) ) &
621  & )
622 
623  allocate( judge( &
624 
625  & answer_shape(1) ) &
626  & )
627 
628  allocate( judge_rev( &
629 
630  & answer_shape(1) ) &
631  & )
632 
633 
634  allocate( answer_fixed_length( &
635 
636  & answer_shape(1) ) &
637  & )
638 
639  allocate( check_fixed_length( &
640 
641  & check_shape(1) ) &
642  & )
643 
644  answer_fixed_length = answer
645  check_fixed_length = check
646 
647  judge = answer_fixed_length == check_fixed_length
648  deallocate(answer_fixed_length, check_fixed_length)
649 
650 
651 
652  judge_rev = .not. judge
653  err_flag = any(judge_rev)
654  mask_array = 1
655  pos = maxloc(mask_array, judge_rev)
656 
657  if (err_flag) then
658 
659  wrong = check( &
660 
661  & pos(1) )
662 
663  right = answer( &
664 
665  & pos(1) )
666 
667  write(unit=pos_array(1), fmt="(i20)") pos(1)
668 
669 
670  pos_str = '(' // &
671 
672  & trim(adjustl(pos_array(1))) // ')'
673 
674  end if
675  deallocate(mask_array, judge, judge_rev)
676 
677 
678 
679 
680  if (err_flag) then
681  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
682  write(*,*) ''
683  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
684  write(*,*) ' is NOT EQUAL to'
685  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
686 
687  call abortprogram('')
688  else
689  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
690  end if
691 
692 
693  end subroutine dctestassertequalchar1
694 
695 
696  subroutine dctestassertequalchar2(message, answer, check)
697  use sysdep, only: abortprogram
698  use dc_types, only: string, token
699  implicit none
700  character(*), intent(in):: message
701  character(*), intent(in):: answer(:,:)
702  character(*), intent(in):: check(:,:)
703  logical:: err_flag
704  character(STRING):: pos_str
705  character(STRING):: wrong, right
706 
707  integer:: answer_shape(2), check_shape(2), pos(2)
708  logical:: consist_shape(2)
709  character(TOKEN):: pos_array(2)
710  integer, allocatable:: mask_array(:,:)
711  logical, allocatable:: judge(:,:)
712  logical, allocatable:: judge_rev(:,:)
713 
714 
715  character(STRING), allocatable:: answer_fixed_length(:,:)
716  character(STRING), allocatable:: check_fixed_length(:,:)
717 
718 
719 
720  continue
721  err_flag = .false.
722 
723 
724  answer_shape = shape(answer)
725  check_shape = shape(check)
726 
727  consist_shape = answer_shape == check_shape
728 
729  if (.not. all(consist_shape)) then
730  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
731  write(*,*) ''
732  write(*,*) ' shape of check is (', check_shape, ')'
733  write(*,*) ' is INCORRECT'
734  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
735 
736  call abortprogram('')
737  end if
738 
739 
740  allocate( mask_array( &
741  & answer_shape(1), &
742 
743  & answer_shape(2) ) &
744  & )
745 
746  allocate( judge( &
747  & answer_shape(1), &
748 
749  & answer_shape(2) ) &
750  & )
751 
752  allocate( judge_rev( &
753  & answer_shape(1), &
754 
755  & answer_shape(2) ) &
756  & )
757 
758 
759  allocate( answer_fixed_length( &
760  & answer_shape(1), &
761 
762  & answer_shape(2) ) &
763  & )
764 
765  allocate( check_fixed_length( &
766  & check_shape(1), &
767 
768  & check_shape(2) ) &
769  & )
770 
771  answer_fixed_length = answer
772  check_fixed_length = check
773 
774  judge = answer_fixed_length == check_fixed_length
775  deallocate(answer_fixed_length, check_fixed_length)
776 
777 
778 
779  judge_rev = .not. judge
780  err_flag = any(judge_rev)
781  mask_array = 1
782  pos = maxloc(mask_array, judge_rev)
783 
784  if (err_flag) then
785 
786  wrong = check( &
787  & pos(1), &
788 
789  & pos(2) )
790 
791  right = answer( &
792  & pos(1), &
793 
794  & pos(2) )
795 
796  write(unit=pos_array(1), fmt="(i20)") pos(1)
797 
798  write(unit=pos_array(2), fmt="(i20)") pos(2)
799 
800 
801  pos_str = '(' // &
802  & trim(adjustl(pos_array(1))) // ',' // &
803 
804  & trim(adjustl(pos_array(2))) // ')'
805 
806  end if
807  deallocate(mask_array, judge, judge_rev)
808 
809 
810 
811 
812  if (err_flag) then
813  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
814  write(*,*) ''
815  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
816  write(*,*) ' is NOT EQUAL to'
817  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
818 
819  call abortprogram('')
820  else
821  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
822  end if
823 
824 
825  end subroutine dctestassertequalchar2
826 
827 
828  subroutine dctestassertequalchar3(message, answer, check)
829  use sysdep, only: abortprogram
830  use dc_types, only: string, token
831  implicit none
832  character(*), intent(in):: message
833  character(*), intent(in):: answer(:,:,:)
834  character(*), intent(in):: check(:,:,:)
835  logical:: err_flag
836  character(STRING):: pos_str
837  character(STRING):: wrong, right
838 
839  integer:: answer_shape(3), check_shape(3), pos(3)
840  logical:: consist_shape(3)
841  character(TOKEN):: pos_array(3)
842  integer, allocatable:: mask_array(:,:,:)
843  logical, allocatable:: judge(:,:,:)
844  logical, allocatable:: judge_rev(:,:,:)
845 
846 
847  character(STRING), allocatable:: answer_fixed_length(:,:,:)
848  character(STRING), allocatable:: check_fixed_length(:,:,:)
849 
850 
851 
852  continue
853  err_flag = .false.
854 
855 
856  answer_shape = shape(answer)
857  check_shape = shape(check)
858 
859  consist_shape = answer_shape == check_shape
860 
861  if (.not. all(consist_shape)) then
862  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
863  write(*,*) ''
864  write(*,*) ' shape of check is (', check_shape, ')'
865  write(*,*) ' is INCORRECT'
866  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
867 
868  call abortprogram('')
869  end if
870 
871 
872  allocate( mask_array( &
873  & answer_shape(1), &
874 
875  & answer_shape(2), &
876 
877  & answer_shape(3) ) &
878  & )
879 
880  allocate( judge( &
881  & answer_shape(1), &
882 
883  & answer_shape(2), &
884 
885  & answer_shape(3) ) &
886  & )
887 
888  allocate( judge_rev( &
889  & answer_shape(1), &
890 
891  & answer_shape(2), &
892 
893  & answer_shape(3) ) &
894  & )
895 
896 
897  allocate( answer_fixed_length( &
898  & answer_shape(1), &
899 
900  & answer_shape(2), &
901 
902  & answer_shape(3) ) &
903  & )
904 
905  allocate( check_fixed_length( &
906  & check_shape(1), &
907 
908  & check_shape(2), &
909 
910  & check_shape(3) ) &
911  & )
912 
913  answer_fixed_length = answer
914  check_fixed_length = check
915 
916  judge = answer_fixed_length == check_fixed_length
917  deallocate(answer_fixed_length, check_fixed_length)
918 
919 
920 
921  judge_rev = .not. judge
922  err_flag = any(judge_rev)
923  mask_array = 1
924  pos = maxloc(mask_array, judge_rev)
925 
926  if (err_flag) then
927 
928  wrong = check( &
929  & pos(1), &
930 
931  & pos(2), &
932 
933  & pos(3) )
934 
935  right = answer( &
936  & pos(1), &
937 
938  & pos(2), &
939 
940  & pos(3) )
941 
942  write(unit=pos_array(1), fmt="(i20)") pos(1)
943 
944  write(unit=pos_array(2), fmt="(i20)") pos(2)
945 
946  write(unit=pos_array(3), fmt="(i20)") pos(3)
947 
948 
949  pos_str = '(' // &
950  & trim(adjustl(pos_array(1))) // ',' // &
951 
952  & trim(adjustl(pos_array(2))) // ',' // &
953 
954  & trim(adjustl(pos_array(3))) // ')'
955 
956  end if
957  deallocate(mask_array, judge, judge_rev)
958 
959 
960 
961 
962  if (err_flag) then
963  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
964  write(*,*) ''
965  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
966  write(*,*) ' is NOT EQUAL to'
967  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
968 
969  call abortprogram('')
970  else
971  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
972  end if
973 
974 
975  end subroutine dctestassertequalchar3
976 
977 
978  subroutine dctestassertequalchar4(message, answer, check)
979  use sysdep, only: abortprogram
980  use dc_types, only: string, token
981  implicit none
982  character(*), intent(in):: message
983  character(*), intent(in):: answer(:,:,:,:)
984  character(*), intent(in):: check(:,:,:,:)
985  logical:: err_flag
986  character(STRING):: pos_str
987  character(STRING):: wrong, right
988 
989  integer:: answer_shape(4), check_shape(4), pos(4)
990  logical:: consist_shape(4)
991  character(TOKEN):: pos_array(4)
992  integer, allocatable:: mask_array(:,:,:,:)
993  logical, allocatable:: judge(:,:,:,:)
994  logical, allocatable:: judge_rev(:,:,:,:)
995 
996 
997  character(STRING), allocatable:: answer_fixed_length(:,:,:,:)
998  character(STRING), allocatable:: check_fixed_length(:,:,:,:)
999 
1000 
1001 
1002  continue
1003  err_flag = .false.
1004 
1005 
1006  answer_shape = shape(answer)
1007  check_shape = shape(check)
1008 
1009  consist_shape = answer_shape == check_shape
1010 
1011  if (.not. all(consist_shape)) then
1012  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1013  write(*,*) ''
1014  write(*,*) ' shape of check is (', check_shape, ')'
1015  write(*,*) ' is INCORRECT'
1016  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1017 
1018  call abortprogram('')
1019  end if
1020 
1021 
1022  allocate( mask_array( &
1023  & answer_shape(1), &
1024 
1025  & answer_shape(2), &
1026 
1027  & answer_shape(3), &
1028 
1029  & answer_shape(4) ) &
1030  & )
1031 
1032  allocate( judge( &
1033  & answer_shape(1), &
1034 
1035  & answer_shape(2), &
1036 
1037  & answer_shape(3), &
1038 
1039  & answer_shape(4) ) &
1040  & )
1041 
1042  allocate( judge_rev( &
1043  & answer_shape(1), &
1044 
1045  & answer_shape(2), &
1046 
1047  & answer_shape(3), &
1048 
1049  & answer_shape(4) ) &
1050  & )
1051 
1052 
1053  allocate( answer_fixed_length( &
1054  & answer_shape(1), &
1055 
1056  & answer_shape(2), &
1057 
1058  & answer_shape(3), &
1059 
1060  & answer_shape(4) ) &
1061  & )
1062 
1063  allocate( check_fixed_length( &
1064  & check_shape(1), &
1065 
1066  & check_shape(2), &
1067 
1068  & check_shape(3), &
1069 
1070  & check_shape(4) ) &
1071  & )
1072 
1073  answer_fixed_length = answer
1074  check_fixed_length = check
1075 
1076  judge = answer_fixed_length == check_fixed_length
1077  deallocate(answer_fixed_length, check_fixed_length)
1078 
1079 
1080 
1081  judge_rev = .not. judge
1082  err_flag = any(judge_rev)
1083  mask_array = 1
1084  pos = maxloc(mask_array, judge_rev)
1085 
1086  if (err_flag) then
1087 
1088  wrong = check( &
1089  & pos(1), &
1090 
1091  & pos(2), &
1092 
1093  & pos(3), &
1094 
1095  & pos(4) )
1096 
1097  right = answer( &
1098  & pos(1), &
1099 
1100  & pos(2), &
1101 
1102  & pos(3), &
1103 
1104  & pos(4) )
1105 
1106  write(unit=pos_array(1), fmt="(i20)") pos(1)
1107 
1108  write(unit=pos_array(2), fmt="(i20)") pos(2)
1109 
1110  write(unit=pos_array(3), fmt="(i20)") pos(3)
1111 
1112  write(unit=pos_array(4), fmt="(i20)") pos(4)
1113 
1114 
1115  pos_str = '(' // &
1116  & trim(adjustl(pos_array(1))) // ',' // &
1117 
1118  & trim(adjustl(pos_array(2))) // ',' // &
1119 
1120  & trim(adjustl(pos_array(3))) // ',' // &
1121 
1122  & trim(adjustl(pos_array(4))) // ')'
1123 
1124  end if
1125  deallocate(mask_array, judge, judge_rev)
1126 
1127 
1128 
1129 
1130  if (err_flag) then
1131  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1132  write(*,*) ''
1133  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1134  write(*,*) ' is NOT EQUAL to'
1135  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1136 
1137  call abortprogram('')
1138  else
1139  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1140  end if
1141 
1142 
1143  end subroutine dctestassertequalchar4
1144 
1145 
1146  subroutine dctestassertequalchar5(message, answer, check)
1147  use sysdep, only: abortprogram
1148  use dc_types, only: string, token
1149  implicit none
1150  character(*), intent(in):: message
1151  character(*), intent(in):: answer(:,:,:,:,:)
1152  character(*), intent(in):: check(:,:,:,:,:)
1153  logical:: err_flag
1154  character(STRING):: pos_str
1155  character(STRING):: wrong, right
1156 
1157  integer:: answer_shape(5), check_shape(5), pos(5)
1158  logical:: consist_shape(5)
1159  character(TOKEN):: pos_array(5)
1160  integer, allocatable:: mask_array(:,:,:,:,:)
1161  logical, allocatable:: judge(:,:,:,:,:)
1162  logical, allocatable:: judge_rev(:,:,:,:,:)
1163 
1164 
1165  character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:)
1166  character(STRING), allocatable:: check_fixed_length(:,:,:,:,:)
1167 
1168 
1169 
1170  continue
1171  err_flag = .false.
1172 
1173 
1174  answer_shape = shape(answer)
1175  check_shape = shape(check)
1176 
1177  consist_shape = answer_shape == check_shape
1178 
1179  if (.not. all(consist_shape)) then
1180  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1181  write(*,*) ''
1182  write(*,*) ' shape of check is (', check_shape, ')'
1183  write(*,*) ' is INCORRECT'
1184  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1185 
1186  call abortprogram('')
1187  end if
1188 
1189 
1190  allocate( mask_array( &
1191  & answer_shape(1), &
1192 
1193  & answer_shape(2), &
1194 
1195  & answer_shape(3), &
1196 
1197  & answer_shape(4), &
1198 
1199  & answer_shape(5) ) &
1200  & )
1201 
1202  allocate( judge( &
1203  & answer_shape(1), &
1204 
1205  & answer_shape(2), &
1206 
1207  & answer_shape(3), &
1208 
1209  & answer_shape(4), &
1210 
1211  & answer_shape(5) ) &
1212  & )
1213 
1214  allocate( judge_rev( &
1215  & answer_shape(1), &
1216 
1217  & answer_shape(2), &
1218 
1219  & answer_shape(3), &
1220 
1221  & answer_shape(4), &
1222 
1223  & answer_shape(5) ) &
1224  & )
1225 
1226 
1227  allocate( answer_fixed_length( &
1228  & answer_shape(1), &
1229 
1230  & answer_shape(2), &
1231 
1232  & answer_shape(3), &
1233 
1234  & answer_shape(4), &
1235 
1236  & answer_shape(5) ) &
1237  & )
1238 
1239  allocate( check_fixed_length( &
1240  & check_shape(1), &
1241 
1242  & check_shape(2), &
1243 
1244  & check_shape(3), &
1245 
1246  & check_shape(4), &
1247 
1248  & check_shape(5) ) &
1249  & )
1250 
1251  answer_fixed_length = answer
1252  check_fixed_length = check
1253 
1254  judge = answer_fixed_length == check_fixed_length
1255  deallocate(answer_fixed_length, check_fixed_length)
1256 
1257 
1258 
1259  judge_rev = .not. judge
1260  err_flag = any(judge_rev)
1261  mask_array = 1
1262  pos = maxloc(mask_array, judge_rev)
1263 
1264  if (err_flag) then
1265 
1266  wrong = check( &
1267  & pos(1), &
1268 
1269  & pos(2), &
1270 
1271  & pos(3), &
1272 
1273  & pos(4), &
1274 
1275  & pos(5) )
1276 
1277  right = answer( &
1278  & pos(1), &
1279 
1280  & pos(2), &
1281 
1282  & pos(3), &
1283 
1284  & pos(4), &
1285 
1286  & pos(5) )
1287 
1288  write(unit=pos_array(1), fmt="(i20)") pos(1)
1289 
1290  write(unit=pos_array(2), fmt="(i20)") pos(2)
1291 
1292  write(unit=pos_array(3), fmt="(i20)") pos(3)
1293 
1294  write(unit=pos_array(4), fmt="(i20)") pos(4)
1295 
1296  write(unit=pos_array(5), fmt="(i20)") pos(5)
1297 
1298 
1299  pos_str = '(' // &
1300  & trim(adjustl(pos_array(1))) // ',' // &
1301 
1302  & trim(adjustl(pos_array(2))) // ',' // &
1303 
1304  & trim(adjustl(pos_array(3))) // ',' // &
1305 
1306  & trim(adjustl(pos_array(4))) // ',' // &
1307 
1308  & trim(adjustl(pos_array(5))) // ')'
1309 
1310  end if
1311  deallocate(mask_array, judge, judge_rev)
1312 
1313 
1314 
1315 
1316  if (err_flag) then
1317  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1318  write(*,*) ''
1319  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1320  write(*,*) ' is NOT EQUAL to'
1321  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1322 
1323  call abortprogram('')
1324  else
1325  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1326  end if
1327 
1328 
1329  end subroutine dctestassertequalchar5
1330 
1331 
1332  subroutine dctestassertequalchar6(message, answer, check)
1333  use sysdep, only: abortprogram
1334  use dc_types, only: string, token
1335  implicit none
1336  character(*), intent(in):: message
1337  character(*), intent(in):: answer(:,:,:,:,:,:)
1338  character(*), intent(in):: check(:,:,:,:,:,:)
1339  logical:: err_flag
1340  character(STRING):: pos_str
1341  character(STRING):: wrong, right
1342 
1343  integer:: answer_shape(6), check_shape(6), pos(6)
1344  logical:: consist_shape(6)
1345  character(TOKEN):: pos_array(6)
1346  integer, allocatable:: mask_array(:,:,:,:,:,:)
1347  logical, allocatable:: judge(:,:,:,:,:,:)
1348  logical, allocatable:: judge_rev(:,:,:,:,:,:)
1349 
1350 
1351  character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:)
1352  character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:)
1353 
1354 
1355 
1356  continue
1357  err_flag = .false.
1358 
1359 
1360  answer_shape = shape(answer)
1361  check_shape = shape(check)
1362 
1363  consist_shape = answer_shape == check_shape
1364 
1365  if (.not. all(consist_shape)) then
1366  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1367  write(*,*) ''
1368  write(*,*) ' shape of check is (', check_shape, ')'
1369  write(*,*) ' is INCORRECT'
1370  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1371 
1372  call abortprogram('')
1373  end if
1374 
1375 
1376  allocate( mask_array( &
1377  & answer_shape(1), &
1378 
1379  & answer_shape(2), &
1380 
1381  & answer_shape(3), &
1382 
1383  & answer_shape(4), &
1384 
1385  & answer_shape(5), &
1386 
1387  & answer_shape(6) ) &
1388  & )
1389 
1390  allocate( judge( &
1391  & answer_shape(1), &
1392 
1393  & answer_shape(2), &
1394 
1395  & answer_shape(3), &
1396 
1397  & answer_shape(4), &
1398 
1399  & answer_shape(5), &
1400 
1401  & answer_shape(6) ) &
1402  & )
1403 
1404  allocate( judge_rev( &
1405  & answer_shape(1), &
1406 
1407  & answer_shape(2), &
1408 
1409  & answer_shape(3), &
1410 
1411  & answer_shape(4), &
1412 
1413  & answer_shape(5), &
1414 
1415  & answer_shape(6) ) &
1416  & )
1417 
1418 
1419  allocate( answer_fixed_length( &
1420  & answer_shape(1), &
1421 
1422  & answer_shape(2), &
1423 
1424  & answer_shape(3), &
1425 
1426  & answer_shape(4), &
1427 
1428  & answer_shape(5), &
1429 
1430  & answer_shape(6) ) &
1431  & )
1432 
1433  allocate( check_fixed_length( &
1434  & check_shape(1), &
1435 
1436  & check_shape(2), &
1437 
1438  & check_shape(3), &
1439 
1440  & check_shape(4), &
1441 
1442  & check_shape(5), &
1443 
1444  & check_shape(6) ) &
1445  & )
1446 
1447  answer_fixed_length = answer
1448  check_fixed_length = check
1449 
1450  judge = answer_fixed_length == check_fixed_length
1451  deallocate(answer_fixed_length, check_fixed_length)
1452 
1453 
1454 
1455  judge_rev = .not. judge
1456  err_flag = any(judge_rev)
1457  mask_array = 1
1458  pos = maxloc(mask_array, judge_rev)
1459 
1460  if (err_flag) then
1461 
1462  wrong = check( &
1463  & pos(1), &
1464 
1465  & pos(2), &
1466 
1467  & pos(3), &
1468 
1469  & pos(4), &
1470 
1471  & pos(5), &
1472 
1473  & pos(6) )
1474 
1475  right = answer( &
1476  & pos(1), &
1477 
1478  & pos(2), &
1479 
1480  & pos(3), &
1481 
1482  & pos(4), &
1483 
1484  & pos(5), &
1485 
1486  & pos(6) )
1487 
1488  write(unit=pos_array(1), fmt="(i20)") pos(1)
1489 
1490  write(unit=pos_array(2), fmt="(i20)") pos(2)
1491 
1492  write(unit=pos_array(3), fmt="(i20)") pos(3)
1493 
1494  write(unit=pos_array(4), fmt="(i20)") pos(4)
1495 
1496  write(unit=pos_array(5), fmt="(i20)") pos(5)
1497 
1498  write(unit=pos_array(6), fmt="(i20)") pos(6)
1499 
1500 
1501  pos_str = '(' // &
1502  & trim(adjustl(pos_array(1))) // ',' // &
1503 
1504  & trim(adjustl(pos_array(2))) // ',' // &
1505 
1506  & trim(adjustl(pos_array(3))) // ',' // &
1507 
1508  & trim(adjustl(pos_array(4))) // ',' // &
1509 
1510  & trim(adjustl(pos_array(5))) // ',' // &
1511 
1512  & trim(adjustl(pos_array(6))) // ')'
1513 
1514  end if
1515  deallocate(mask_array, judge, judge_rev)
1516 
1517 
1518 
1519 
1520  if (err_flag) then
1521  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1522  write(*,*) ''
1523  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1524  write(*,*) ' is NOT EQUAL to'
1525  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1526 
1527  call abortprogram('')
1528  else
1529  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1530  end if
1531 
1532 
1533  end subroutine dctestassertequalchar6
1534 
1535 
1536  subroutine dctestassertequalchar7(message, answer, check)
1537  use sysdep, only: abortprogram
1538  use dc_types, only: string, token
1539  implicit none
1540  character(*), intent(in):: message
1541  character(*), intent(in):: answer(:,:,:,:,:,:,:)
1542  character(*), intent(in):: check(:,:,:,:,:,:,:)
1543  logical:: err_flag
1544  character(STRING):: pos_str
1545  character(STRING):: wrong, right
1546 
1547  integer:: answer_shape(7), check_shape(7), pos(7)
1548  logical:: consist_shape(7)
1549  character(TOKEN):: pos_array(7)
1550  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
1551  logical, allocatable:: judge(:,:,:,:,:,:,:)
1552  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
1553 
1554 
1555  character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:,:)
1556  character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:,:)
1557 
1558 
1559 
1560  continue
1561  err_flag = .false.
1562 
1563 
1564  answer_shape = shape(answer)
1565  check_shape = shape(check)
1566 
1567  consist_shape = answer_shape == check_shape
1568 
1569  if (.not. all(consist_shape)) then
1570  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1571  write(*,*) ''
1572  write(*,*) ' shape of check is (', check_shape, ')'
1573  write(*,*) ' is INCORRECT'
1574  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1575 
1576  call abortprogram('')
1577  end if
1578 
1579 
1580  allocate( mask_array( &
1581  & answer_shape(1), &
1582 
1583  & answer_shape(2), &
1584 
1585  & answer_shape(3), &
1586 
1587  & answer_shape(4), &
1588 
1589  & answer_shape(5), &
1590 
1591  & answer_shape(6), &
1592 
1593  & answer_shape(7) ) &
1594  & )
1595 
1596  allocate( judge( &
1597  & answer_shape(1), &
1598 
1599  & answer_shape(2), &
1600 
1601  & answer_shape(3), &
1602 
1603  & answer_shape(4), &
1604 
1605  & answer_shape(5), &
1606 
1607  & answer_shape(6), &
1608 
1609  & answer_shape(7) ) &
1610  & )
1611 
1612  allocate( judge_rev( &
1613  & answer_shape(1), &
1614 
1615  & answer_shape(2), &
1616 
1617  & answer_shape(3), &
1618 
1619  & answer_shape(4), &
1620 
1621  & answer_shape(5), &
1622 
1623  & answer_shape(6), &
1624 
1625  & answer_shape(7) ) &
1626  & )
1627 
1628 
1629  allocate( answer_fixed_length( &
1630  & answer_shape(1), &
1631 
1632  & answer_shape(2), &
1633 
1634  & answer_shape(3), &
1635 
1636  & answer_shape(4), &
1637 
1638  & answer_shape(5), &
1639 
1640  & answer_shape(6), &
1641 
1642  & answer_shape(7) ) &
1643  & )
1644 
1645  allocate( check_fixed_length( &
1646  & check_shape(1), &
1647 
1648  & check_shape(2), &
1649 
1650  & check_shape(3), &
1651 
1652  & check_shape(4), &
1653 
1654  & check_shape(5), &
1655 
1656  & check_shape(6), &
1657 
1658  & check_shape(7) ) &
1659  & )
1660 
1661  answer_fixed_length = answer
1662  check_fixed_length = check
1663 
1664  judge = answer_fixed_length == check_fixed_length
1665  deallocate(answer_fixed_length, check_fixed_length)
1666 
1667 
1668 
1669  judge_rev = .not. judge
1670  err_flag = any(judge_rev)
1671  mask_array = 1
1672  pos = maxloc(mask_array, judge_rev)
1673 
1674  if (err_flag) then
1675 
1676  wrong = check( &
1677  & pos(1), &
1678 
1679  & pos(2), &
1680 
1681  & pos(3), &
1682 
1683  & pos(4), &
1684 
1685  & pos(5), &
1686 
1687  & pos(6), &
1688 
1689  & pos(7) )
1690 
1691  right = answer( &
1692  & pos(1), &
1693 
1694  & pos(2), &
1695 
1696  & pos(3), &
1697 
1698  & pos(4), &
1699 
1700  & pos(5), &
1701 
1702  & pos(6), &
1703 
1704  & pos(7) )
1705 
1706  write(unit=pos_array(1), fmt="(i20)") pos(1)
1707 
1708  write(unit=pos_array(2), fmt="(i20)") pos(2)
1709 
1710  write(unit=pos_array(3), fmt="(i20)") pos(3)
1711 
1712  write(unit=pos_array(4), fmt="(i20)") pos(4)
1713 
1714  write(unit=pos_array(5), fmt="(i20)") pos(5)
1715 
1716  write(unit=pos_array(6), fmt="(i20)") pos(6)
1717 
1718  write(unit=pos_array(7), fmt="(i20)") pos(7)
1719 
1720 
1721  pos_str = '(' // &
1722  & trim(adjustl(pos_array(1))) // ',' // &
1723 
1724  & trim(adjustl(pos_array(2))) // ',' // &
1725 
1726  & trim(adjustl(pos_array(3))) // ',' // &
1727 
1728  & trim(adjustl(pos_array(4))) // ',' // &
1729 
1730  & trim(adjustl(pos_array(5))) // ',' // &
1731 
1732  & trim(adjustl(pos_array(6))) // ',' // &
1733 
1734  & trim(adjustl(pos_array(7))) // ')'
1735 
1736  end if
1737  deallocate(mask_array, judge, judge_rev)
1738 
1739 
1740 
1741 
1742  if (err_flag) then
1743  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1744  write(*,*) ''
1745  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1746  write(*,*) ' is NOT EQUAL to'
1747  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1748 
1749  call abortprogram('')
1750  else
1751  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1752  end if
1753 
1754 
1755  end subroutine dctestassertequalchar7
1756 
1757 
1758  subroutine dctestassertequalint0(message, answer, check)
1759  use sysdep, only: abortprogram
1760  use dc_types, only: string, token
1761  implicit none
1762  character(*), intent(in):: message
1763  integer, intent(in):: answer
1764  integer, intent(in):: check
1765  logical:: err_flag
1766  character(STRING):: pos_str
1767  integer:: wrong, right
1768 
1769 
1770 
1771 
1772 
1773  continue
1774  err_flag = .false.
1775 
1776 
1777  err_flag = .not. answer == check
1778  wrong = check
1779  right = answer
1780  pos_str = ''
1781 
1782 
1783 
1784 
1785  if (err_flag) then
1786  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1787  write(*,*) ''
1788  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1789  write(*,*) ' is NOT EQUAL to'
1790  write(*,*) ' answer' // trim(pos_str) // ' = ', right
1791 
1792  call abortprogram('')
1793  else
1794  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1795  end if
1796 
1797 
1798  end subroutine dctestassertequalint0
1799 
1800 
1801  subroutine dctestassertequalint1(message, answer, check)
1802  use sysdep, only: abortprogram
1803  use dc_types, only: string, token
1804  implicit none
1805  character(*), intent(in):: message
1806  integer, intent(in):: answer(:)
1807  integer, intent(in):: check(:)
1808  logical:: err_flag
1809  character(STRING):: pos_str
1810  integer:: wrong, right
1811 
1812  integer:: answer_shape(1), check_shape(1), pos(1)
1813  logical:: consist_shape(1)
1814  character(TOKEN):: pos_array(1)
1815  integer, allocatable:: mask_array(:)
1816  logical, allocatable:: judge(:)
1817  logical, allocatable:: judge_rev(:)
1818 
1819 
1820 
1821 
1822  continue
1823  err_flag = .false.
1824 
1825 
1826  answer_shape = shape(answer)
1827  check_shape = shape(check)
1828 
1829  consist_shape = answer_shape == check_shape
1830 
1831  if (.not. all(consist_shape)) then
1832  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1833  write(*,*) ''
1834  write(*,*) ' shape of check is (', check_shape, ')'
1835  write(*,*) ' is INCORRECT'
1836  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1837 
1838  call abortprogram('')
1839  end if
1840 
1841 
1842  allocate( mask_array( &
1843 
1844  & answer_shape(1) ) &
1845  & )
1846 
1847  allocate( judge( &
1848 
1849  & answer_shape(1) ) &
1850  & )
1851 
1852  allocate( judge_rev( &
1853 
1854  & answer_shape(1) ) &
1855  & )
1856 
1857 
1858  judge = answer == check
1859 
1860 
1861 
1862  judge_rev = .not. judge
1863  err_flag = any(judge_rev)
1864  mask_array = 1
1865  pos = maxloc(mask_array, judge_rev)
1866 
1867  if (err_flag) then
1868 
1869  wrong = check( &
1870 
1871  & pos(1) )
1872 
1873  right = answer( &
1874 
1875  & pos(1) )
1876 
1877  write(unit=pos_array(1), fmt="(i20)") pos(1)
1878 
1879 
1880  pos_str = '(' // &
1881 
1882  & trim(adjustl(pos_array(1))) // ')'
1883 
1884  end if
1885  deallocate(mask_array, judge, judge_rev)
1886 
1887 
1888 
1889 
1890  if (err_flag) then
1891  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1892  write(*,*) ''
1893  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1894  write(*,*) ' is NOT EQUAL to'
1895  write(*,*) ' answer' // trim(pos_str) // ' = ', right
1896 
1897  call abortprogram('')
1898  else
1899  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1900  end if
1901 
1902 
1903  end subroutine dctestassertequalint1
1904 
1905 
1906  subroutine dctestassertequalint2(message, answer, check)
1907  use sysdep, only: abortprogram
1908  use dc_types, only: string, token
1909  implicit none
1910  character(*), intent(in):: message
1911  integer, intent(in):: answer(:,:)
1912  integer, intent(in):: check(:,:)
1913  logical:: err_flag
1914  character(STRING):: pos_str
1915  integer:: wrong, right
1916 
1917  integer:: answer_shape(2), check_shape(2), pos(2)
1918  logical:: consist_shape(2)
1919  character(TOKEN):: pos_array(2)
1920  integer, allocatable:: mask_array(:,:)
1921  logical, allocatable:: judge(:,:)
1922  logical, allocatable:: judge_rev(:,:)
1923 
1924 
1925 
1926 
1927  continue
1928  err_flag = .false.
1929 
1930 
1931  answer_shape = shape(answer)
1932  check_shape = shape(check)
1933 
1934  consist_shape = answer_shape == check_shape
1935 
1936  if (.not. all(consist_shape)) then
1937  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1938  write(*,*) ''
1939  write(*,*) ' shape of check is (', check_shape, ')'
1940  write(*,*) ' is INCORRECT'
1941  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1942 
1943  call abortprogram('')
1944  end if
1945 
1946 
1947  allocate( mask_array( &
1948  & answer_shape(1), &
1949 
1950  & answer_shape(2) ) &
1951  & )
1952 
1953  allocate( judge( &
1954  & answer_shape(1), &
1955 
1956  & answer_shape(2) ) &
1957  & )
1958 
1959  allocate( judge_rev( &
1960  & answer_shape(1), &
1961 
1962  & answer_shape(2) ) &
1963  & )
1964 
1965 
1966  judge = answer == check
1967 
1968 
1969 
1970  judge_rev = .not. judge
1971  err_flag = any(judge_rev)
1972  mask_array = 1
1973  pos = maxloc(mask_array, judge_rev)
1974 
1975  if (err_flag) then
1976 
1977  wrong = check( &
1978  & pos(1), &
1979 
1980  & pos(2) )
1981 
1982  right = answer( &
1983  & pos(1), &
1984 
1985  & pos(2) )
1986 
1987  write(unit=pos_array(1), fmt="(i20)") pos(1)
1988 
1989  write(unit=pos_array(2), fmt="(i20)") pos(2)
1990 
1991 
1992  pos_str = '(' // &
1993  & trim(adjustl(pos_array(1))) // ',' // &
1994 
1995  & trim(adjustl(pos_array(2))) // ')'
1996 
1997  end if
1998  deallocate(mask_array, judge, judge_rev)
1999 
2000 
2001 
2002 
2003  if (err_flag) then
2004  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2005  write(*,*) ''
2006  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2007  write(*,*) ' is NOT EQUAL to'
2008  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2009 
2010  call abortprogram('')
2011  else
2012  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2013  end if
2014 
2015 
2016  end subroutine dctestassertequalint2
2017 
2018 
2019  subroutine dctestassertequalint3(message, answer, check)
2020  use sysdep, only: abortprogram
2021  use dc_types, only: string, token
2022  implicit none
2023  character(*), intent(in):: message
2024  integer, intent(in):: answer(:,:,:)
2025  integer, intent(in):: check(:,:,:)
2026  logical:: err_flag
2027  character(STRING):: pos_str
2028  integer:: wrong, right
2029 
2030  integer:: answer_shape(3), check_shape(3), pos(3)
2031  logical:: consist_shape(3)
2032  character(TOKEN):: pos_array(3)
2033  integer, allocatable:: mask_array(:,:,:)
2034  logical, allocatable:: judge(:,:,:)
2035  logical, allocatable:: judge_rev(:,:,:)
2036 
2037 
2038 
2039 
2040  continue
2041  err_flag = .false.
2042 
2043 
2044  answer_shape = shape(answer)
2045  check_shape = shape(check)
2046 
2047  consist_shape = answer_shape == check_shape
2048 
2049  if (.not. all(consist_shape)) then
2050  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2051  write(*,*) ''
2052  write(*,*) ' shape of check is (', check_shape, ')'
2053  write(*,*) ' is INCORRECT'
2054  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2055 
2056  call abortprogram('')
2057  end if
2058 
2059 
2060  allocate( mask_array( &
2061  & answer_shape(1), &
2062 
2063  & answer_shape(2), &
2064 
2065  & answer_shape(3) ) &
2066  & )
2067 
2068  allocate( judge( &
2069  & answer_shape(1), &
2070 
2071  & answer_shape(2), &
2072 
2073  & answer_shape(3) ) &
2074  & )
2075 
2076  allocate( judge_rev( &
2077  & answer_shape(1), &
2078 
2079  & answer_shape(2), &
2080 
2081  & answer_shape(3) ) &
2082  & )
2083 
2084 
2085  judge = answer == check
2086 
2087 
2088 
2089  judge_rev = .not. judge
2090  err_flag = any(judge_rev)
2091  mask_array = 1
2092  pos = maxloc(mask_array, judge_rev)
2093 
2094  if (err_flag) then
2095 
2096  wrong = check( &
2097  & pos(1), &
2098 
2099  & pos(2), &
2100 
2101  & pos(3) )
2102 
2103  right = answer( &
2104  & pos(1), &
2105 
2106  & pos(2), &
2107 
2108  & pos(3) )
2109 
2110  write(unit=pos_array(1), fmt="(i20)") pos(1)
2111 
2112  write(unit=pos_array(2), fmt="(i20)") pos(2)
2113 
2114  write(unit=pos_array(3), fmt="(i20)") pos(3)
2115 
2116 
2117  pos_str = '(' // &
2118  & trim(adjustl(pos_array(1))) // ',' // &
2119 
2120  & trim(adjustl(pos_array(2))) // ',' // &
2121 
2122  & trim(adjustl(pos_array(3))) // ')'
2123 
2124  end if
2125  deallocate(mask_array, judge, judge_rev)
2126 
2127 
2128 
2129 
2130  if (err_flag) then
2131  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2132  write(*,*) ''
2133  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2134  write(*,*) ' is NOT EQUAL to'
2135  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2136 
2137  call abortprogram('')
2138  else
2139  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2140  end if
2141 
2142 
2143  end subroutine dctestassertequalint3
2144 
2145 
2146  subroutine dctestassertequalint4(message, answer, check)
2147  use sysdep, only: abortprogram
2148  use dc_types, only: string, token
2149  implicit none
2150  character(*), intent(in):: message
2151  integer, intent(in):: answer(:,:,:,:)
2152  integer, intent(in):: check(:,:,:,:)
2153  logical:: err_flag
2154  character(STRING):: pos_str
2155  integer:: wrong, right
2156 
2157  integer:: answer_shape(4), check_shape(4), pos(4)
2158  logical:: consist_shape(4)
2159  character(TOKEN):: pos_array(4)
2160  integer, allocatable:: mask_array(:,:,:,:)
2161  logical, allocatable:: judge(:,:,:,:)
2162  logical, allocatable:: judge_rev(:,:,:,:)
2163 
2164 
2165 
2166 
2167  continue
2168  err_flag = .false.
2169 
2170 
2171  answer_shape = shape(answer)
2172  check_shape = shape(check)
2173 
2174  consist_shape = answer_shape == check_shape
2175 
2176  if (.not. all(consist_shape)) then
2177  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2178  write(*,*) ''
2179  write(*,*) ' shape of check is (', check_shape, ')'
2180  write(*,*) ' is INCORRECT'
2181  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2182 
2183  call abortprogram('')
2184  end if
2185 
2186 
2187  allocate( mask_array( &
2188  & answer_shape(1), &
2189 
2190  & answer_shape(2), &
2191 
2192  & answer_shape(3), &
2193 
2194  & answer_shape(4) ) &
2195  & )
2196 
2197  allocate( judge( &
2198  & answer_shape(1), &
2199 
2200  & answer_shape(2), &
2201 
2202  & answer_shape(3), &
2203 
2204  & answer_shape(4) ) &
2205  & )
2206 
2207  allocate( judge_rev( &
2208  & answer_shape(1), &
2209 
2210  & answer_shape(2), &
2211 
2212  & answer_shape(3), &
2213 
2214  & answer_shape(4) ) &
2215  & )
2216 
2217 
2218  judge = answer == check
2219 
2220 
2221 
2222  judge_rev = .not. judge
2223  err_flag = any(judge_rev)
2224  mask_array = 1
2225  pos = maxloc(mask_array, judge_rev)
2226 
2227  if (err_flag) then
2228 
2229  wrong = check( &
2230  & pos(1), &
2231 
2232  & pos(2), &
2233 
2234  & pos(3), &
2235 
2236  & pos(4) )
2237 
2238  right = answer( &
2239  & pos(1), &
2240 
2241  & pos(2), &
2242 
2243  & pos(3), &
2244 
2245  & pos(4) )
2246 
2247  write(unit=pos_array(1), fmt="(i20)") pos(1)
2248 
2249  write(unit=pos_array(2), fmt="(i20)") pos(2)
2250 
2251  write(unit=pos_array(3), fmt="(i20)") pos(3)
2252 
2253  write(unit=pos_array(4), fmt="(i20)") pos(4)
2254 
2255 
2256  pos_str = '(' // &
2257  & trim(adjustl(pos_array(1))) // ',' // &
2258 
2259  & trim(adjustl(pos_array(2))) // ',' // &
2260 
2261  & trim(adjustl(pos_array(3))) // ',' // &
2262 
2263  & trim(adjustl(pos_array(4))) // ')'
2264 
2265  end if
2266  deallocate(mask_array, judge, judge_rev)
2267 
2268 
2269 
2270 
2271  if (err_flag) then
2272  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2273  write(*,*) ''
2274  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2275  write(*,*) ' is NOT EQUAL to'
2276  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2277 
2278  call abortprogram('')
2279  else
2280  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2281  end if
2282 
2283 
2284  end subroutine dctestassertequalint4
2285 
2286 
2287  subroutine dctestassertequalint5(message, answer, check)
2288  use sysdep, only: abortprogram
2289  use dc_types, only: string, token
2290  implicit none
2291  character(*), intent(in):: message
2292  integer, intent(in):: answer(:,:,:,:,:)
2293  integer, intent(in):: check(:,:,:,:,:)
2294  logical:: err_flag
2295  character(STRING):: pos_str
2296  integer:: wrong, right
2297 
2298  integer:: answer_shape(5), check_shape(5), pos(5)
2299  logical:: consist_shape(5)
2300  character(TOKEN):: pos_array(5)
2301  integer, allocatable:: mask_array(:,:,:,:,:)
2302  logical, allocatable:: judge(:,:,:,:,:)
2303  logical, allocatable:: judge_rev(:,:,:,:,:)
2304 
2305 
2306 
2307 
2308  continue
2309  err_flag = .false.
2310 
2311 
2312  answer_shape = shape(answer)
2313  check_shape = shape(check)
2314 
2315  consist_shape = answer_shape == check_shape
2316 
2317  if (.not. all(consist_shape)) then
2318  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2319  write(*,*) ''
2320  write(*,*) ' shape of check is (', check_shape, ')'
2321  write(*,*) ' is INCORRECT'
2322  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2323 
2324  call abortprogram('')
2325  end if
2326 
2327 
2328  allocate( mask_array( &
2329  & answer_shape(1), &
2330 
2331  & answer_shape(2), &
2332 
2333  & answer_shape(3), &
2334 
2335  & answer_shape(4), &
2336 
2337  & answer_shape(5) ) &
2338  & )
2339 
2340  allocate( judge( &
2341  & answer_shape(1), &
2342 
2343  & answer_shape(2), &
2344 
2345  & answer_shape(3), &
2346 
2347  & answer_shape(4), &
2348 
2349  & answer_shape(5) ) &
2350  & )
2351 
2352  allocate( judge_rev( &
2353  & answer_shape(1), &
2354 
2355  & answer_shape(2), &
2356 
2357  & answer_shape(3), &
2358 
2359  & answer_shape(4), &
2360 
2361  & answer_shape(5) ) &
2362  & )
2363 
2364 
2365  judge = answer == check
2366 
2367 
2368 
2369  judge_rev = .not. judge
2370  err_flag = any(judge_rev)
2371  mask_array = 1
2372  pos = maxloc(mask_array, judge_rev)
2373 
2374  if (err_flag) then
2375 
2376  wrong = check( &
2377  & pos(1), &
2378 
2379  & pos(2), &
2380 
2381  & pos(3), &
2382 
2383  & pos(4), &
2384 
2385  & pos(5) )
2386 
2387  right = answer( &
2388  & pos(1), &
2389 
2390  & pos(2), &
2391 
2392  & pos(3), &
2393 
2394  & pos(4), &
2395 
2396  & pos(5) )
2397 
2398  write(unit=pos_array(1), fmt="(i20)") pos(1)
2399 
2400  write(unit=pos_array(2), fmt="(i20)") pos(2)
2401 
2402  write(unit=pos_array(3), fmt="(i20)") pos(3)
2403 
2404  write(unit=pos_array(4), fmt="(i20)") pos(4)
2405 
2406  write(unit=pos_array(5), fmt="(i20)") pos(5)
2407 
2408 
2409  pos_str = '(' // &
2410  & trim(adjustl(pos_array(1))) // ',' // &
2411 
2412  & trim(adjustl(pos_array(2))) // ',' // &
2413 
2414  & trim(adjustl(pos_array(3))) // ',' // &
2415 
2416  & trim(adjustl(pos_array(4))) // ',' // &
2417 
2418  & trim(adjustl(pos_array(5))) // ')'
2419 
2420  end if
2421  deallocate(mask_array, judge, judge_rev)
2422 
2423 
2424 
2425 
2426  if (err_flag) then
2427  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2428  write(*,*) ''
2429  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2430  write(*,*) ' is NOT EQUAL to'
2431  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2432 
2433  call abortprogram('')
2434  else
2435  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2436  end if
2437 
2438 
2439  end subroutine dctestassertequalint5
2440 
2441 
2442  subroutine dctestassertequalint6(message, answer, check)
2443  use sysdep, only: abortprogram
2444  use dc_types, only: string, token
2445  implicit none
2446  character(*), intent(in):: message
2447  integer, intent(in):: answer(:,:,:,:,:,:)
2448  integer, intent(in):: check(:,:,:,:,:,:)
2449  logical:: err_flag
2450  character(STRING):: pos_str
2451  integer:: wrong, right
2452 
2453  integer:: answer_shape(6), check_shape(6), pos(6)
2454  logical:: consist_shape(6)
2455  character(TOKEN):: pos_array(6)
2456  integer, allocatable:: mask_array(:,:,:,:,:,:)
2457  logical, allocatable:: judge(:,:,:,:,:,:)
2458  logical, allocatable:: judge_rev(:,:,:,:,:,:)
2459 
2460 
2461 
2462 
2463  continue
2464  err_flag = .false.
2465 
2466 
2467  answer_shape = shape(answer)
2468  check_shape = shape(check)
2469 
2470  consist_shape = answer_shape == check_shape
2471 
2472  if (.not. all(consist_shape)) then
2473  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2474  write(*,*) ''
2475  write(*,*) ' shape of check is (', check_shape, ')'
2476  write(*,*) ' is INCORRECT'
2477  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2478 
2479  call abortprogram('')
2480  end if
2481 
2482 
2483  allocate( mask_array( &
2484  & answer_shape(1), &
2485 
2486  & answer_shape(2), &
2487 
2488  & answer_shape(3), &
2489 
2490  & answer_shape(4), &
2491 
2492  & answer_shape(5), &
2493 
2494  & answer_shape(6) ) &
2495  & )
2496 
2497  allocate( judge( &
2498  & answer_shape(1), &
2499 
2500  & answer_shape(2), &
2501 
2502  & answer_shape(3), &
2503 
2504  & answer_shape(4), &
2505 
2506  & answer_shape(5), &
2507 
2508  & answer_shape(6) ) &
2509  & )
2510 
2511  allocate( judge_rev( &
2512  & answer_shape(1), &
2513 
2514  & answer_shape(2), &
2515 
2516  & answer_shape(3), &
2517 
2518  & answer_shape(4), &
2519 
2520  & answer_shape(5), &
2521 
2522  & answer_shape(6) ) &
2523  & )
2524 
2525 
2526  judge = answer == check
2527 
2528 
2529 
2530  judge_rev = .not. judge
2531  err_flag = any(judge_rev)
2532  mask_array = 1
2533  pos = maxloc(mask_array, judge_rev)
2534 
2535  if (err_flag) then
2536 
2537  wrong = check( &
2538  & pos(1), &
2539 
2540  & pos(2), &
2541 
2542  & pos(3), &
2543 
2544  & pos(4), &
2545 
2546  & pos(5), &
2547 
2548  & pos(6) )
2549 
2550  right = answer( &
2551  & pos(1), &
2552 
2553  & pos(2), &
2554 
2555  & pos(3), &
2556 
2557  & pos(4), &
2558 
2559  & pos(5), &
2560 
2561  & pos(6) )
2562 
2563  write(unit=pos_array(1), fmt="(i20)") pos(1)
2564 
2565  write(unit=pos_array(2), fmt="(i20)") pos(2)
2566 
2567  write(unit=pos_array(3), fmt="(i20)") pos(3)
2568 
2569  write(unit=pos_array(4), fmt="(i20)") pos(4)
2570 
2571  write(unit=pos_array(5), fmt="(i20)") pos(5)
2572 
2573  write(unit=pos_array(6), fmt="(i20)") pos(6)
2574 
2575 
2576  pos_str = '(' // &
2577  & trim(adjustl(pos_array(1))) // ',' // &
2578 
2579  & trim(adjustl(pos_array(2))) // ',' // &
2580 
2581  & trim(adjustl(pos_array(3))) // ',' // &
2582 
2583  & trim(adjustl(pos_array(4))) // ',' // &
2584 
2585  & trim(adjustl(pos_array(5))) // ',' // &
2586 
2587  & trim(adjustl(pos_array(6))) // ')'
2588 
2589  end if
2590  deallocate(mask_array, judge, judge_rev)
2591 
2592 
2593 
2594 
2595  if (err_flag) then
2596  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2597  write(*,*) ''
2598  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2599  write(*,*) ' is NOT EQUAL to'
2600  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2601 
2602  call abortprogram('')
2603  else
2604  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2605  end if
2606 
2607 
2608  end subroutine dctestassertequalint6
2609 
2610 
2611  subroutine dctestassertequalint7(message, answer, check)
2612  use sysdep, only: abortprogram
2613  use dc_types, only: string, token
2614  implicit none
2615  character(*), intent(in):: message
2616  integer, intent(in):: answer(:,:,:,:,:,:,:)
2617  integer, intent(in):: check(:,:,:,:,:,:,:)
2618  logical:: err_flag
2619  character(STRING):: pos_str
2620  integer:: wrong, right
2621 
2622  integer:: answer_shape(7), check_shape(7), pos(7)
2623  logical:: consist_shape(7)
2624  character(TOKEN):: pos_array(7)
2625  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
2626  logical, allocatable:: judge(:,:,:,:,:,:,:)
2627  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
2628 
2629 
2630 
2631 
2632  continue
2633  err_flag = .false.
2634 
2635 
2636  answer_shape = shape(answer)
2637  check_shape = shape(check)
2638 
2639  consist_shape = answer_shape == check_shape
2640 
2641  if (.not. all(consist_shape)) then
2642  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2643  write(*,*) ''
2644  write(*,*) ' shape of check is (', check_shape, ')'
2645  write(*,*) ' is INCORRECT'
2646  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2647 
2648  call abortprogram('')
2649  end if
2650 
2651 
2652  allocate( mask_array( &
2653  & answer_shape(1), &
2654 
2655  & answer_shape(2), &
2656 
2657  & answer_shape(3), &
2658 
2659  & answer_shape(4), &
2660 
2661  & answer_shape(5), &
2662 
2663  & answer_shape(6), &
2664 
2665  & answer_shape(7) ) &
2666  & )
2667 
2668  allocate( judge( &
2669  & answer_shape(1), &
2670 
2671  & answer_shape(2), &
2672 
2673  & answer_shape(3), &
2674 
2675  & answer_shape(4), &
2676 
2677  & answer_shape(5), &
2678 
2679  & answer_shape(6), &
2680 
2681  & answer_shape(7) ) &
2682  & )
2683 
2684  allocate( judge_rev( &
2685  & answer_shape(1), &
2686 
2687  & answer_shape(2), &
2688 
2689  & answer_shape(3), &
2690 
2691  & answer_shape(4), &
2692 
2693  & answer_shape(5), &
2694 
2695  & answer_shape(6), &
2696 
2697  & answer_shape(7) ) &
2698  & )
2699 
2700 
2701  judge = answer == check
2702 
2703 
2704 
2705  judge_rev = .not. judge
2706  err_flag = any(judge_rev)
2707  mask_array = 1
2708  pos = maxloc(mask_array, judge_rev)
2709 
2710  if (err_flag) then
2711 
2712  wrong = check( &
2713  & pos(1), &
2714 
2715  & pos(2), &
2716 
2717  & pos(3), &
2718 
2719  & pos(4), &
2720 
2721  & pos(5), &
2722 
2723  & pos(6), &
2724 
2725  & pos(7) )
2726 
2727  right = answer( &
2728  & pos(1), &
2729 
2730  & pos(2), &
2731 
2732  & pos(3), &
2733 
2734  & pos(4), &
2735 
2736  & pos(5), &
2737 
2738  & pos(6), &
2739 
2740  & pos(7) )
2741 
2742  write(unit=pos_array(1), fmt="(i20)") pos(1)
2743 
2744  write(unit=pos_array(2), fmt="(i20)") pos(2)
2745 
2746  write(unit=pos_array(3), fmt="(i20)") pos(3)
2747 
2748  write(unit=pos_array(4), fmt="(i20)") pos(4)
2749 
2750  write(unit=pos_array(5), fmt="(i20)") pos(5)
2751 
2752  write(unit=pos_array(6), fmt="(i20)") pos(6)
2753 
2754  write(unit=pos_array(7), fmt="(i20)") pos(7)
2755 
2756 
2757  pos_str = '(' // &
2758  & trim(adjustl(pos_array(1))) // ',' // &
2759 
2760  & trim(adjustl(pos_array(2))) // ',' // &
2761 
2762  & trim(adjustl(pos_array(3))) // ',' // &
2763 
2764  & trim(adjustl(pos_array(4))) // ',' // &
2765 
2766  & trim(adjustl(pos_array(5))) // ',' // &
2767 
2768  & trim(adjustl(pos_array(6))) // ',' // &
2769 
2770  & trim(adjustl(pos_array(7))) // ')'
2771 
2772  end if
2773  deallocate(mask_array, judge, judge_rev)
2774 
2775 
2776 
2777 
2778  if (err_flag) then
2779  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2780  write(*,*) ''
2781  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2782  write(*,*) ' is NOT EQUAL to'
2783  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2784 
2785  call abortprogram('')
2786  else
2787  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2788  end if
2789 
2790 
2791  end subroutine dctestassertequalint7
2792 
2793 
2794  subroutine dctestassertequalreal0(message, answer, check)
2795  use sysdep, only: abortprogram
2796  use dc_types, only: string, token
2797  implicit none
2798  character(*), intent(in):: message
2799  real, intent(in):: answer
2800  real, intent(in):: check
2801  logical:: err_flag
2802  character(STRING):: pos_str
2803  real:: wrong, right
2804 
2805 
2806 
2807 
2808 
2809  continue
2810  err_flag = .false.
2811 
2812 
2813  err_flag = .not. answer == check
2814  wrong = check
2815  right = answer
2816  pos_str = ''
2817 
2818 
2819 
2820 
2821  if (err_flag) then
2822  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2823  write(*,*) ''
2824  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2825  write(*,*) ' is NOT EQUAL to'
2826  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2827 
2828  call abortprogram('')
2829  else
2830  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2831  end if
2832 
2833 
2834  end subroutine dctestassertequalreal0
2835 
2836 
2837  subroutine dctestassertequalreal1(message, answer, check)
2838  use sysdep, only: abortprogram
2839  use dc_types, only: string, token
2840  implicit none
2841  character(*), intent(in):: message
2842  real, intent(in):: answer(:)
2843  real, intent(in):: check(:)
2844  logical:: err_flag
2845  character(STRING):: pos_str
2846  real:: wrong, right
2847 
2848  integer:: answer_shape(1), check_shape(1), pos(1)
2849  logical:: consist_shape(1)
2850  character(TOKEN):: pos_array(1)
2851  integer, allocatable:: mask_array(:)
2852  logical, allocatable:: judge(:)
2853  logical, allocatable:: judge_rev(:)
2854 
2855 
2856 
2857 
2858  continue
2859  err_flag = .false.
2860 
2861 
2862  answer_shape = shape(answer)
2863  check_shape = shape(check)
2864 
2865  consist_shape = answer_shape == check_shape
2866 
2867  if (.not. all(consist_shape)) then
2868  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2869  write(*,*) ''
2870  write(*,*) ' shape of check is (', check_shape, ')'
2871  write(*,*) ' is INCORRECT'
2872  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2873 
2874  call abortprogram('')
2875  end if
2876 
2877 
2878  allocate( mask_array( &
2879 
2880  & answer_shape(1) ) &
2881  & )
2882 
2883  allocate( judge( &
2884 
2885  & answer_shape(1) ) &
2886  & )
2887 
2888  allocate( judge_rev( &
2889 
2890  & answer_shape(1) ) &
2891  & )
2892 
2893 
2894  judge = answer == check
2895 
2896 
2897 
2898  judge_rev = .not. judge
2899  err_flag = any(judge_rev)
2900  mask_array = 1
2901  pos = maxloc(mask_array, judge_rev)
2902 
2903  if (err_flag) then
2904 
2905  wrong = check( &
2906 
2907  & pos(1) )
2908 
2909  right = answer( &
2910 
2911  & pos(1) )
2912 
2913  write(unit=pos_array(1), fmt="(i20)") pos(1)
2914 
2915 
2916  pos_str = '(' // &
2917 
2918  & trim(adjustl(pos_array(1))) // ')'
2919 
2920  end if
2921  deallocate(mask_array, judge, judge_rev)
2922 
2923 
2924 
2925 
2926  if (err_flag) then
2927  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2928  write(*,*) ''
2929  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2930  write(*,*) ' is NOT EQUAL to'
2931  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2932 
2933  call abortprogram('')
2934  else
2935  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2936  end if
2937 
2938 
2939  end subroutine dctestassertequalreal1
2940 
2941 
2942  subroutine dctestassertequalreal2(message, answer, check)
2943  use sysdep, only: abortprogram
2944  use dc_types, only: string, token
2945  implicit none
2946  character(*), intent(in):: message
2947  real, intent(in):: answer(:,:)
2948  real, intent(in):: check(:,:)
2949  logical:: err_flag
2950  character(STRING):: pos_str
2951  real:: wrong, right
2952 
2953  integer:: answer_shape(2), check_shape(2), pos(2)
2954  logical:: consist_shape(2)
2955  character(TOKEN):: pos_array(2)
2956  integer, allocatable:: mask_array(:,:)
2957  logical, allocatable:: judge(:,:)
2958  logical, allocatable:: judge_rev(:,:)
2959 
2960 
2961 
2962 
2963  continue
2964  err_flag = .false.
2965 
2966 
2967  answer_shape = shape(answer)
2968  check_shape = shape(check)
2969 
2970  consist_shape = answer_shape == check_shape
2971 
2972  if (.not. all(consist_shape)) then
2973  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2974  write(*,*) ''
2975  write(*,*) ' shape of check is (', check_shape, ')'
2976  write(*,*) ' is INCORRECT'
2977  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2978 
2979  call abortprogram('')
2980  end if
2981 
2982 
2983  allocate( mask_array( &
2984  & answer_shape(1), &
2985 
2986  & answer_shape(2) ) &
2987  & )
2988 
2989  allocate( judge( &
2990  & answer_shape(1), &
2991 
2992  & answer_shape(2) ) &
2993  & )
2994 
2995  allocate( judge_rev( &
2996  & answer_shape(1), &
2997 
2998  & answer_shape(2) ) &
2999  & )
3000 
3001 
3002  judge = answer == check
3003 
3004 
3005 
3006  judge_rev = .not. judge
3007  err_flag = any(judge_rev)
3008  mask_array = 1
3009  pos = maxloc(mask_array, judge_rev)
3010 
3011  if (err_flag) then
3012 
3013  wrong = check( &
3014  & pos(1), &
3015 
3016  & pos(2) )
3017 
3018  right = answer( &
3019  & pos(1), &
3020 
3021  & pos(2) )
3022 
3023  write(unit=pos_array(1), fmt="(i20)") pos(1)
3024 
3025  write(unit=pos_array(2), fmt="(i20)") pos(2)
3026 
3027 
3028  pos_str = '(' // &
3029  & trim(adjustl(pos_array(1))) // ',' // &
3030 
3031  & trim(adjustl(pos_array(2))) // ')'
3032 
3033  end if
3034  deallocate(mask_array, judge, judge_rev)
3035 
3036 
3037 
3038 
3039  if (err_flag) then
3040  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3041  write(*,*) ''
3042  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3043  write(*,*) ' is NOT EQUAL to'
3044  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3045 
3046  call abortprogram('')
3047  else
3048  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3049  end if
3050 
3051 
3052  end subroutine dctestassertequalreal2
3053 
3054 
3055  subroutine dctestassertequalreal3(message, answer, check)
3056  use sysdep, only: abortprogram
3057  use dc_types, only: string, token
3058  implicit none
3059  character(*), intent(in):: message
3060  real, intent(in):: answer(:,:,:)
3061  real, intent(in):: check(:,:,:)
3062  logical:: err_flag
3063  character(STRING):: pos_str
3064  real:: wrong, right
3065 
3066  integer:: answer_shape(3), check_shape(3), pos(3)
3067  logical:: consist_shape(3)
3068  character(TOKEN):: pos_array(3)
3069  integer, allocatable:: mask_array(:,:,:)
3070  logical, allocatable:: judge(:,:,:)
3071  logical, allocatable:: judge_rev(:,:,:)
3072 
3073 
3074 
3075 
3076  continue
3077  err_flag = .false.
3078 
3079 
3080  answer_shape = shape(answer)
3081  check_shape = shape(check)
3082 
3083  consist_shape = answer_shape == check_shape
3084 
3085  if (.not. all(consist_shape)) then
3086  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3087  write(*,*) ''
3088  write(*,*) ' shape of check is (', check_shape, ')'
3089  write(*,*) ' is INCORRECT'
3090  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3091 
3092  call abortprogram('')
3093  end if
3094 
3095 
3096  allocate( mask_array( &
3097  & answer_shape(1), &
3098 
3099  & answer_shape(2), &
3100 
3101  & answer_shape(3) ) &
3102  & )
3103 
3104  allocate( judge( &
3105  & answer_shape(1), &
3106 
3107  & answer_shape(2), &
3108 
3109  & answer_shape(3) ) &
3110  & )
3111 
3112  allocate( judge_rev( &
3113  & answer_shape(1), &
3114 
3115  & answer_shape(2), &
3116 
3117  & answer_shape(3) ) &
3118  & )
3119 
3120 
3121  judge = answer == check
3122 
3123 
3124 
3125  judge_rev = .not. judge
3126  err_flag = any(judge_rev)
3127  mask_array = 1
3128  pos = maxloc(mask_array, judge_rev)
3129 
3130  if (err_flag) then
3131 
3132  wrong = check( &
3133  & pos(1), &
3134 
3135  & pos(2), &
3136 
3137  & pos(3) )
3138 
3139  right = answer( &
3140  & pos(1), &
3141 
3142  & pos(2), &
3143 
3144  & pos(3) )
3145 
3146  write(unit=pos_array(1), fmt="(i20)") pos(1)
3147 
3148  write(unit=pos_array(2), fmt="(i20)") pos(2)
3149 
3150  write(unit=pos_array(3), fmt="(i20)") pos(3)
3151 
3152 
3153  pos_str = '(' // &
3154  & trim(adjustl(pos_array(1))) // ',' // &
3155 
3156  & trim(adjustl(pos_array(2))) // ',' // &
3157 
3158  & trim(adjustl(pos_array(3))) // ')'
3159 
3160  end if
3161  deallocate(mask_array, judge, judge_rev)
3162 
3163 
3164 
3165 
3166  if (err_flag) then
3167  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3168  write(*,*) ''
3169  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3170  write(*,*) ' is NOT EQUAL to'
3171  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3172 
3173  call abortprogram('')
3174  else
3175  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3176  end if
3177 
3178 
3179  end subroutine dctestassertequalreal3
3180 
3181 
3182  subroutine dctestassertequalreal4(message, answer, check)
3183  use sysdep, only: abortprogram
3184  use dc_types, only: string, token
3185  implicit none
3186  character(*), intent(in):: message
3187  real, intent(in):: answer(:,:,:,:)
3188  real, intent(in):: check(:,:,:,:)
3189  logical:: err_flag
3190  character(STRING):: pos_str
3191  real:: wrong, right
3192 
3193  integer:: answer_shape(4), check_shape(4), pos(4)
3194  logical:: consist_shape(4)
3195  character(TOKEN):: pos_array(4)
3196  integer, allocatable:: mask_array(:,:,:,:)
3197  logical, allocatable:: judge(:,:,:,:)
3198  logical, allocatable:: judge_rev(:,:,:,:)
3199 
3200 
3201 
3202 
3203  continue
3204  err_flag = .false.
3205 
3206 
3207  answer_shape = shape(answer)
3208  check_shape = shape(check)
3209 
3210  consist_shape = answer_shape == check_shape
3211 
3212  if (.not. all(consist_shape)) then
3213  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3214  write(*,*) ''
3215  write(*,*) ' shape of check is (', check_shape, ')'
3216  write(*,*) ' is INCORRECT'
3217  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3218 
3219  call abortprogram('')
3220  end if
3221 
3222 
3223  allocate( mask_array( &
3224  & answer_shape(1), &
3225 
3226  & answer_shape(2), &
3227 
3228  & answer_shape(3), &
3229 
3230  & answer_shape(4) ) &
3231  & )
3232 
3233  allocate( judge( &
3234  & answer_shape(1), &
3235 
3236  & answer_shape(2), &
3237 
3238  & answer_shape(3), &
3239 
3240  & answer_shape(4) ) &
3241  & )
3242 
3243  allocate( judge_rev( &
3244  & answer_shape(1), &
3245 
3246  & answer_shape(2), &
3247 
3248  & answer_shape(3), &
3249 
3250  & answer_shape(4) ) &
3251  & )
3252 
3253 
3254  judge = answer == check
3255 
3256 
3257 
3258  judge_rev = .not. judge
3259  err_flag = any(judge_rev)
3260  mask_array = 1
3261  pos = maxloc(mask_array, judge_rev)
3262 
3263  if (err_flag) then
3264 
3265  wrong = check( &
3266  & pos(1), &
3267 
3268  & pos(2), &
3269 
3270  & pos(3), &
3271 
3272  & pos(4) )
3273 
3274  right = answer( &
3275  & pos(1), &
3276 
3277  & pos(2), &
3278 
3279  & pos(3), &
3280 
3281  & pos(4) )
3282 
3283  write(unit=pos_array(1), fmt="(i20)") pos(1)
3284 
3285  write(unit=pos_array(2), fmt="(i20)") pos(2)
3286 
3287  write(unit=pos_array(3), fmt="(i20)") pos(3)
3288 
3289  write(unit=pos_array(4), fmt="(i20)") pos(4)
3290 
3291 
3292  pos_str = '(' // &
3293  & trim(adjustl(pos_array(1))) // ',' // &
3294 
3295  & trim(adjustl(pos_array(2))) // ',' // &
3296 
3297  & trim(adjustl(pos_array(3))) // ',' // &
3298 
3299  & trim(adjustl(pos_array(4))) // ')'
3300 
3301  end if
3302  deallocate(mask_array, judge, judge_rev)
3303 
3304 
3305 
3306 
3307  if (err_flag) then
3308  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3309  write(*,*) ''
3310  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3311  write(*,*) ' is NOT EQUAL to'
3312  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3313 
3314  call abortprogram('')
3315  else
3316  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3317  end if
3318 
3319 
3320  end subroutine dctestassertequalreal4
3321 
3322 
3323  subroutine dctestassertequalreal5(message, answer, check)
3324  use sysdep, only: abortprogram
3325  use dc_types, only: string, token
3326  implicit none
3327  character(*), intent(in):: message
3328  real, intent(in):: answer(:,:,:,:,:)
3329  real, intent(in):: check(:,:,:,:,:)
3330  logical:: err_flag
3331  character(STRING):: pos_str
3332  real:: wrong, right
3333 
3334  integer:: answer_shape(5), check_shape(5), pos(5)
3335  logical:: consist_shape(5)
3336  character(TOKEN):: pos_array(5)
3337  integer, allocatable:: mask_array(:,:,:,:,:)
3338  logical, allocatable:: judge(:,:,:,:,:)
3339  logical, allocatable:: judge_rev(:,:,:,:,:)
3340 
3341 
3342 
3343 
3344  continue
3345  err_flag = .false.
3346 
3347 
3348  answer_shape = shape(answer)
3349  check_shape = shape(check)
3350 
3351  consist_shape = answer_shape == check_shape
3352 
3353  if (.not. all(consist_shape)) then
3354  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3355  write(*,*) ''
3356  write(*,*) ' shape of check is (', check_shape, ')'
3357  write(*,*) ' is INCORRECT'
3358  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3359 
3360  call abortprogram('')
3361  end if
3362 
3363 
3364  allocate( mask_array( &
3365  & answer_shape(1), &
3366 
3367  & answer_shape(2), &
3368 
3369  & answer_shape(3), &
3370 
3371  & answer_shape(4), &
3372 
3373  & answer_shape(5) ) &
3374  & )
3375 
3376  allocate( judge( &
3377  & answer_shape(1), &
3378 
3379  & answer_shape(2), &
3380 
3381  & answer_shape(3), &
3382 
3383  & answer_shape(4), &
3384 
3385  & answer_shape(5) ) &
3386  & )
3387 
3388  allocate( judge_rev( &
3389  & answer_shape(1), &
3390 
3391  & answer_shape(2), &
3392 
3393  & answer_shape(3), &
3394 
3395  & answer_shape(4), &
3396 
3397  & answer_shape(5) ) &
3398  & )
3399 
3400 
3401  judge = answer == check
3402 
3403 
3404 
3405  judge_rev = .not. judge
3406  err_flag = any(judge_rev)
3407  mask_array = 1
3408  pos = maxloc(mask_array, judge_rev)
3409 
3410  if (err_flag) then
3411 
3412  wrong = check( &
3413  & pos(1), &
3414 
3415  & pos(2), &
3416 
3417  & pos(3), &
3418 
3419  & pos(4), &
3420 
3421  & pos(5) )
3422 
3423  right = answer( &
3424  & pos(1), &
3425 
3426  & pos(2), &
3427 
3428  & pos(3), &
3429 
3430  & pos(4), &
3431 
3432  & pos(5) )
3433 
3434  write(unit=pos_array(1), fmt="(i20)") pos(1)
3435 
3436  write(unit=pos_array(2), fmt="(i20)") pos(2)
3437 
3438  write(unit=pos_array(3), fmt="(i20)") pos(3)
3439 
3440  write(unit=pos_array(4), fmt="(i20)") pos(4)
3441 
3442  write(unit=pos_array(5), fmt="(i20)") pos(5)
3443 
3444 
3445  pos_str = '(' // &
3446  & trim(adjustl(pos_array(1))) // ',' // &
3447 
3448  & trim(adjustl(pos_array(2))) // ',' // &
3449 
3450  & trim(adjustl(pos_array(3))) // ',' // &
3451 
3452  & trim(adjustl(pos_array(4))) // ',' // &
3453 
3454  & trim(adjustl(pos_array(5))) // ')'
3455 
3456  end if
3457  deallocate(mask_array, judge, judge_rev)
3458 
3459 
3460 
3461 
3462  if (err_flag) then
3463  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3464  write(*,*) ''
3465  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3466  write(*,*) ' is NOT EQUAL to'
3467  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3468 
3469  call abortprogram('')
3470  else
3471  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3472  end if
3473 
3474 
3475  end subroutine dctestassertequalreal5
3476 
3477 
3478  subroutine dctestassertequalreal6(message, answer, check)
3479  use sysdep, only: abortprogram
3480  use dc_types, only: string, token
3481  implicit none
3482  character(*), intent(in):: message
3483  real, intent(in):: answer(:,:,:,:,:,:)
3484  real, intent(in):: check(:,:,:,:,:,:)
3485  logical:: err_flag
3486  character(STRING):: pos_str
3487  real:: wrong, right
3488 
3489  integer:: answer_shape(6), check_shape(6), pos(6)
3490  logical:: consist_shape(6)
3491  character(TOKEN):: pos_array(6)
3492  integer, allocatable:: mask_array(:,:,:,:,:,:)
3493  logical, allocatable:: judge(:,:,:,:,:,:)
3494  logical, allocatable:: judge_rev(:,:,:,:,:,:)
3495 
3496 
3497 
3498 
3499  continue
3500  err_flag = .false.
3501 
3502 
3503  answer_shape = shape(answer)
3504  check_shape = shape(check)
3505 
3506  consist_shape = answer_shape == check_shape
3507 
3508  if (.not. all(consist_shape)) then
3509  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3510  write(*,*) ''
3511  write(*,*) ' shape of check is (', check_shape, ')'
3512  write(*,*) ' is INCORRECT'
3513  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3514 
3515  call abortprogram('')
3516  end if
3517 
3518 
3519  allocate( mask_array( &
3520  & answer_shape(1), &
3521 
3522  & answer_shape(2), &
3523 
3524  & answer_shape(3), &
3525 
3526  & answer_shape(4), &
3527 
3528  & answer_shape(5), &
3529 
3530  & answer_shape(6) ) &
3531  & )
3532 
3533  allocate( judge( &
3534  & answer_shape(1), &
3535 
3536  & answer_shape(2), &
3537 
3538  & answer_shape(3), &
3539 
3540  & answer_shape(4), &
3541 
3542  & answer_shape(5), &
3543 
3544  & answer_shape(6) ) &
3545  & )
3546 
3547  allocate( judge_rev( &
3548  & answer_shape(1), &
3549 
3550  & answer_shape(2), &
3551 
3552  & answer_shape(3), &
3553 
3554  & answer_shape(4), &
3555 
3556  & answer_shape(5), &
3557 
3558  & answer_shape(6) ) &
3559  & )
3560 
3561 
3562  judge = answer == check
3563 
3564 
3565 
3566  judge_rev = .not. judge
3567  err_flag = any(judge_rev)
3568  mask_array = 1
3569  pos = maxloc(mask_array, judge_rev)
3570 
3571  if (err_flag) then
3572 
3573  wrong = check( &
3574  & pos(1), &
3575 
3576  & pos(2), &
3577 
3578  & pos(3), &
3579 
3580  & pos(4), &
3581 
3582  & pos(5), &
3583 
3584  & pos(6) )
3585 
3586  right = answer( &
3587  & pos(1), &
3588 
3589  & pos(2), &
3590 
3591  & pos(3), &
3592 
3593  & pos(4), &
3594 
3595  & pos(5), &
3596 
3597  & pos(6) )
3598 
3599  write(unit=pos_array(1), fmt="(i20)") pos(1)
3600 
3601  write(unit=pos_array(2), fmt="(i20)") pos(2)
3602 
3603  write(unit=pos_array(3), fmt="(i20)") pos(3)
3604 
3605  write(unit=pos_array(4), fmt="(i20)") pos(4)
3606 
3607  write(unit=pos_array(5), fmt="(i20)") pos(5)
3608 
3609  write(unit=pos_array(6), fmt="(i20)") pos(6)
3610 
3611 
3612  pos_str = '(' // &
3613  & trim(adjustl(pos_array(1))) // ',' // &
3614 
3615  & trim(adjustl(pos_array(2))) // ',' // &
3616 
3617  & trim(adjustl(pos_array(3))) // ',' // &
3618 
3619  & trim(adjustl(pos_array(4))) // ',' // &
3620 
3621  & trim(adjustl(pos_array(5))) // ',' // &
3622 
3623  & trim(adjustl(pos_array(6))) // ')'
3624 
3625  end if
3626  deallocate(mask_array, judge, judge_rev)
3627 
3628 
3629 
3630 
3631  if (err_flag) then
3632  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3633  write(*,*) ''
3634  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3635  write(*,*) ' is NOT EQUAL to'
3636  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3637 
3638  call abortprogram('')
3639  else
3640  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3641  end if
3642 
3643 
3644  end subroutine dctestassertequalreal6
3645 
3646 
3647  subroutine dctestassertequalreal7(message, answer, check)
3648  use sysdep, only: abortprogram
3649  use dc_types, only: string, token
3650  implicit none
3651  character(*), intent(in):: message
3652  real, intent(in):: answer(:,:,:,:,:,:,:)
3653  real, intent(in):: check(:,:,:,:,:,:,:)
3654  logical:: err_flag
3655  character(STRING):: pos_str
3656  real:: wrong, right
3657 
3658  integer:: answer_shape(7), check_shape(7), pos(7)
3659  logical:: consist_shape(7)
3660  character(TOKEN):: pos_array(7)
3661  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
3662  logical, allocatable:: judge(:,:,:,:,:,:,:)
3663  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
3664 
3665 
3666 
3667 
3668  continue
3669  err_flag = .false.
3670 
3671 
3672  answer_shape = shape(answer)
3673  check_shape = shape(check)
3674 
3675  consist_shape = answer_shape == check_shape
3676 
3677  if (.not. all(consist_shape)) then
3678  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3679  write(*,*) ''
3680  write(*,*) ' shape of check is (', check_shape, ')'
3681  write(*,*) ' is INCORRECT'
3682  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3683 
3684  call abortprogram('')
3685  end if
3686 
3687 
3688  allocate( mask_array( &
3689  & answer_shape(1), &
3690 
3691  & answer_shape(2), &
3692 
3693  & answer_shape(3), &
3694 
3695  & answer_shape(4), &
3696 
3697  & answer_shape(5), &
3698 
3699  & answer_shape(6), &
3700 
3701  & answer_shape(7) ) &
3702  & )
3703 
3704  allocate( judge( &
3705  & answer_shape(1), &
3706 
3707  & answer_shape(2), &
3708 
3709  & answer_shape(3), &
3710 
3711  & answer_shape(4), &
3712 
3713  & answer_shape(5), &
3714 
3715  & answer_shape(6), &
3716 
3717  & answer_shape(7) ) &
3718  & )
3719 
3720  allocate( judge_rev( &
3721  & answer_shape(1), &
3722 
3723  & answer_shape(2), &
3724 
3725  & answer_shape(3), &
3726 
3727  & answer_shape(4), &
3728 
3729  & answer_shape(5), &
3730 
3731  & answer_shape(6), &
3732 
3733  & answer_shape(7) ) &
3734  & )
3735 
3736 
3737  judge = answer == check
3738 
3739 
3740 
3741  judge_rev = .not. judge
3742  err_flag = any(judge_rev)
3743  mask_array = 1
3744  pos = maxloc(mask_array, judge_rev)
3745 
3746  if (err_flag) then
3747 
3748  wrong = check( &
3749  & pos(1), &
3750 
3751  & pos(2), &
3752 
3753  & pos(3), &
3754 
3755  & pos(4), &
3756 
3757  & pos(5), &
3758 
3759  & pos(6), &
3760 
3761  & pos(7) )
3762 
3763  right = answer( &
3764  & pos(1), &
3765 
3766  & pos(2), &
3767 
3768  & pos(3), &
3769 
3770  & pos(4), &
3771 
3772  & pos(5), &
3773 
3774  & pos(6), &
3775 
3776  & pos(7) )
3777 
3778  write(unit=pos_array(1), fmt="(i20)") pos(1)
3779 
3780  write(unit=pos_array(2), fmt="(i20)") pos(2)
3781 
3782  write(unit=pos_array(3), fmt="(i20)") pos(3)
3783 
3784  write(unit=pos_array(4), fmt="(i20)") pos(4)
3785 
3786  write(unit=pos_array(5), fmt="(i20)") pos(5)
3787 
3788  write(unit=pos_array(6), fmt="(i20)") pos(6)
3789 
3790  write(unit=pos_array(7), fmt="(i20)") pos(7)
3791 
3792 
3793  pos_str = '(' // &
3794  & trim(adjustl(pos_array(1))) // ',' // &
3795 
3796  & trim(adjustl(pos_array(2))) // ',' // &
3797 
3798  & trim(adjustl(pos_array(3))) // ',' // &
3799 
3800  & trim(adjustl(pos_array(4))) // ',' // &
3801 
3802  & trim(adjustl(pos_array(5))) // ',' // &
3803 
3804  & trim(adjustl(pos_array(6))) // ',' // &
3805 
3806  & trim(adjustl(pos_array(7))) // ')'
3807 
3808  end if
3809  deallocate(mask_array, judge, judge_rev)
3810 
3811 
3812 
3813 
3814  if (err_flag) then
3815  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3816  write(*,*) ''
3817  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3818  write(*,*) ' is NOT EQUAL to'
3819  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3820 
3821  call abortprogram('')
3822  else
3823  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3824  end if
3825 
3826 
3827  end subroutine dctestassertequalreal7
3828 
3829 
3830  subroutine dctestassertequaldouble0(message, answer, check)
3831  use sysdep, only: abortprogram
3832  use dc_types, only: string, token
3833  implicit none
3834  character(*), intent(in):: message
3835  real(DP), intent(in):: answer
3836  real(DP), intent(in):: check
3837  logical:: err_flag
3838  character(STRING):: pos_str
3839  real(DP):: wrong, right
3840 
3841 
3842 
3843 
3844 
3845  continue
3846  err_flag = .false.
3847 
3848 
3849  err_flag = .not. answer == check
3850  wrong = check
3851  right = answer
3852  pos_str = ''
3853 
3854 
3855 
3856 
3857  if (err_flag) then
3858  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3859  write(*,*) ''
3860  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3861  write(*,*) ' is NOT EQUAL to'
3862  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3863 
3864  call abortprogram('')
3865  else
3866  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3867  end if
3868 
3869 
3870  end subroutine dctestassertequaldouble0
3871 
3872 
3873  subroutine dctestassertequaldouble1(message, answer, check)
3874  use sysdep, only: abortprogram
3875  use dc_types, only: string, token
3876  implicit none
3877  character(*), intent(in):: message
3878  real(DP), intent(in):: answer(:)
3879  real(DP), intent(in):: check(:)
3880  logical:: err_flag
3881  character(STRING):: pos_str
3882  real(DP):: wrong, right
3883 
3884  integer:: answer_shape(1), check_shape(1), pos(1)
3885  logical:: consist_shape(1)
3886  character(TOKEN):: pos_array(1)
3887  integer, allocatable:: mask_array(:)
3888  logical, allocatable:: judge(:)
3889  logical, allocatable:: judge_rev(:)
3890 
3891 
3892 
3893 
3894  continue
3895  err_flag = .false.
3896 
3897 
3898  answer_shape = shape(answer)
3899  check_shape = shape(check)
3900 
3901  consist_shape = answer_shape == check_shape
3902 
3903  if (.not. all(consist_shape)) then
3904  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3905  write(*,*) ''
3906  write(*,*) ' shape of check is (', check_shape, ')'
3907  write(*,*) ' is INCORRECT'
3908  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3909 
3910  call abortprogram('')
3911  end if
3912 
3913 
3914  allocate( mask_array( &
3915 
3916  & answer_shape(1) ) &
3917  & )
3918 
3919  allocate( judge( &
3920 
3921  & answer_shape(1) ) &
3922  & )
3923 
3924  allocate( judge_rev( &
3925 
3926  & answer_shape(1) ) &
3927  & )
3928 
3929 
3930  judge = answer == check
3931 
3932 
3933 
3934  judge_rev = .not. judge
3935  err_flag = any(judge_rev)
3936  mask_array = 1
3937  pos = maxloc(mask_array, judge_rev)
3938 
3939  if (err_flag) then
3940 
3941  wrong = check( &
3942 
3943  & pos(1) )
3944 
3945  right = answer( &
3946 
3947  & pos(1) )
3948 
3949  write(unit=pos_array(1), fmt="(i20)") pos(1)
3950 
3951 
3952  pos_str = '(' // &
3953 
3954  & trim(adjustl(pos_array(1))) // ')'
3955 
3956  end if
3957  deallocate(mask_array, judge, judge_rev)
3958 
3959 
3960 
3961 
3962  if (err_flag) then
3963  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3964  write(*,*) ''
3965  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3966  write(*,*) ' is NOT EQUAL to'
3967  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3968 
3969  call abortprogram('')
3970  else
3971  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3972  end if
3973 
3974 
3975  end subroutine dctestassertequaldouble1
3976 
3977 
3978  subroutine dctestassertequaldouble2(message, answer, check)
3979  use sysdep, only: abortprogram
3980  use dc_types, only: string, token
3981  implicit none
3982  character(*), intent(in):: message
3983  real(DP), intent(in):: answer(:,:)
3984  real(DP), intent(in):: check(:,:)
3985  logical:: err_flag
3986  character(STRING):: pos_str
3987  real(DP):: wrong, right
3988 
3989  integer:: answer_shape(2), check_shape(2), pos(2)
3990  logical:: consist_shape(2)
3991  character(TOKEN):: pos_array(2)
3992  integer, allocatable:: mask_array(:,:)
3993  logical, allocatable:: judge(:,:)
3994  logical, allocatable:: judge_rev(:,:)
3995 
3996 
3997 
3998 
3999  continue
4000  err_flag = .false.
4001 
4002 
4003  answer_shape = shape(answer)
4004  check_shape = shape(check)
4005 
4006  consist_shape = answer_shape == check_shape
4007 
4008  if (.not. all(consist_shape)) then
4009  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4010  write(*,*) ''
4011  write(*,*) ' shape of check is (', check_shape, ')'
4012  write(*,*) ' is INCORRECT'
4013  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4014 
4015  call abortprogram('')
4016  end if
4017 
4018 
4019  allocate( mask_array( &
4020  & answer_shape(1), &
4021 
4022  & answer_shape(2) ) &
4023  & )
4024 
4025  allocate( judge( &
4026  & answer_shape(1), &
4027 
4028  & answer_shape(2) ) &
4029  & )
4030 
4031  allocate( judge_rev( &
4032  & answer_shape(1), &
4033 
4034  & answer_shape(2) ) &
4035  & )
4036 
4037 
4038  judge = answer == check
4039 
4040 
4041 
4042  judge_rev = .not. judge
4043  err_flag = any(judge_rev)
4044  mask_array = 1
4045  pos = maxloc(mask_array, judge_rev)
4046 
4047  if (err_flag) then
4048 
4049  wrong = check( &
4050  & pos(1), &
4051 
4052  & pos(2) )
4053 
4054  right = answer( &
4055  & pos(1), &
4056 
4057  & pos(2) )
4058 
4059  write(unit=pos_array(1), fmt="(i20)") pos(1)
4060 
4061  write(unit=pos_array(2), fmt="(i20)") pos(2)
4062 
4063 
4064  pos_str = '(' // &
4065  & trim(adjustl(pos_array(1))) // ',' // &
4066 
4067  & trim(adjustl(pos_array(2))) // ')'
4068 
4069  end if
4070  deallocate(mask_array, judge, judge_rev)
4071 
4072 
4073 
4074 
4075  if (err_flag) then
4076  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4077  write(*,*) ''
4078  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4079  write(*,*) ' is NOT EQUAL to'
4080  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4081 
4082  call abortprogram('')
4083  else
4084  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4085  end if
4086 
4087 
4088  end subroutine dctestassertequaldouble2
4089 
4090 
4091  subroutine dctestassertequaldouble3(message, answer, check)
4092  use sysdep, only: abortprogram
4093  use dc_types, only: string, token
4094  implicit none
4095  character(*), intent(in):: message
4096  real(DP), intent(in):: answer(:,:,:)
4097  real(DP), intent(in):: check(:,:,:)
4098  logical:: err_flag
4099  character(STRING):: pos_str
4100  real(DP):: wrong, right
4101 
4102  integer:: answer_shape(3), check_shape(3), pos(3)
4103  logical:: consist_shape(3)
4104  character(TOKEN):: pos_array(3)
4105  integer, allocatable:: mask_array(:,:,:)
4106  logical, allocatable:: judge(:,:,:)
4107  logical, allocatable:: judge_rev(:,:,:)
4108 
4109 
4110 
4111 
4112  continue
4113  err_flag = .false.
4114 
4115 
4116  answer_shape = shape(answer)
4117  check_shape = shape(check)
4118 
4119  consist_shape = answer_shape == check_shape
4120 
4121  if (.not. all(consist_shape)) then
4122  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4123  write(*,*) ''
4124  write(*,*) ' shape of check is (', check_shape, ')'
4125  write(*,*) ' is INCORRECT'
4126  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4127 
4128  call abortprogram('')
4129  end if
4130 
4131 
4132  allocate( mask_array( &
4133  & answer_shape(1), &
4134 
4135  & answer_shape(2), &
4136 
4137  & answer_shape(3) ) &
4138  & )
4139 
4140  allocate( judge( &
4141  & answer_shape(1), &
4142 
4143  & answer_shape(2), &
4144 
4145  & answer_shape(3) ) &
4146  & )
4147 
4148  allocate( judge_rev( &
4149  & answer_shape(1), &
4150 
4151  & answer_shape(2), &
4152 
4153  & answer_shape(3) ) &
4154  & )
4155 
4156 
4157  judge = answer == check
4158 
4159 
4160 
4161  judge_rev = .not. judge
4162  err_flag = any(judge_rev)
4163  mask_array = 1
4164  pos = maxloc(mask_array, judge_rev)
4165 
4166  if (err_flag) then
4167 
4168  wrong = check( &
4169  & pos(1), &
4170 
4171  & pos(2), &
4172 
4173  & pos(3) )
4174 
4175  right = answer( &
4176  & pos(1), &
4177 
4178  & pos(2), &
4179 
4180  & pos(3) )
4181 
4182  write(unit=pos_array(1), fmt="(i20)") pos(1)
4183 
4184  write(unit=pos_array(2), fmt="(i20)") pos(2)
4185 
4186  write(unit=pos_array(3), fmt="(i20)") pos(3)
4187 
4188 
4189  pos_str = '(' // &
4190  & trim(adjustl(pos_array(1))) // ',' // &
4191 
4192  & trim(adjustl(pos_array(2))) // ',' // &
4193 
4194  & trim(adjustl(pos_array(3))) // ')'
4195 
4196  end if
4197  deallocate(mask_array, judge, judge_rev)
4198 
4199 
4200 
4201 
4202  if (err_flag) then
4203  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4204  write(*,*) ''
4205  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4206  write(*,*) ' is NOT EQUAL to'
4207  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4208 
4209  call abortprogram('')
4210  else
4211  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4212  end if
4213 
4214 
4215  end subroutine dctestassertequaldouble3
4216 
4217 
4218  subroutine dctestassertequaldouble4(message, answer, check)
4219  use sysdep, only: abortprogram
4220  use dc_types, only: string, token
4221  implicit none
4222  character(*), intent(in):: message
4223  real(DP), intent(in):: answer(:,:,:,:)
4224  real(DP), intent(in):: check(:,:,:,:)
4225  logical:: err_flag
4226  character(STRING):: pos_str
4227  real(DP):: wrong, right
4228 
4229  integer:: answer_shape(4), check_shape(4), pos(4)
4230  logical:: consist_shape(4)
4231  character(TOKEN):: pos_array(4)
4232  integer, allocatable:: mask_array(:,:,:,:)
4233  logical, allocatable:: judge(:,:,:,:)
4234  logical, allocatable:: judge_rev(:,:,:,:)
4235 
4236 
4237 
4238 
4239  continue
4240  err_flag = .false.
4241 
4242 
4243  answer_shape = shape(answer)
4244  check_shape = shape(check)
4245 
4246  consist_shape = answer_shape == check_shape
4247 
4248  if (.not. all(consist_shape)) then
4249  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4250  write(*,*) ''
4251  write(*,*) ' shape of check is (', check_shape, ')'
4252  write(*,*) ' is INCORRECT'
4253  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4254 
4255  call abortprogram('')
4256  end if
4257 
4258 
4259  allocate( mask_array( &
4260  & answer_shape(1), &
4261 
4262  & answer_shape(2), &
4263 
4264  & answer_shape(3), &
4265 
4266  & answer_shape(4) ) &
4267  & )
4268 
4269  allocate( judge( &
4270  & answer_shape(1), &
4271 
4272  & answer_shape(2), &
4273 
4274  & answer_shape(3), &
4275 
4276  & answer_shape(4) ) &
4277  & )
4278 
4279  allocate( judge_rev( &
4280  & answer_shape(1), &
4281 
4282  & answer_shape(2), &
4283 
4284  & answer_shape(3), &
4285 
4286  & answer_shape(4) ) &
4287  & )
4288 
4289 
4290  judge = answer == check
4291 
4292 
4293 
4294  judge_rev = .not. judge
4295  err_flag = any(judge_rev)
4296  mask_array = 1
4297  pos = maxloc(mask_array, judge_rev)
4298 
4299  if (err_flag) then
4300 
4301  wrong = check( &
4302  & pos(1), &
4303 
4304  & pos(2), &
4305 
4306  & pos(3), &
4307 
4308  & pos(4) )
4309 
4310  right = answer( &
4311  & pos(1), &
4312 
4313  & pos(2), &
4314 
4315  & pos(3), &
4316 
4317  & pos(4) )
4318 
4319  write(unit=pos_array(1), fmt="(i20)") pos(1)
4320 
4321  write(unit=pos_array(2), fmt="(i20)") pos(2)
4322 
4323  write(unit=pos_array(3), fmt="(i20)") pos(3)
4324 
4325  write(unit=pos_array(4), fmt="(i20)") pos(4)
4326 
4327 
4328  pos_str = '(' // &
4329  & trim(adjustl(pos_array(1))) // ',' // &
4330 
4331  & trim(adjustl(pos_array(2))) // ',' // &
4332 
4333  & trim(adjustl(pos_array(3))) // ',' // &
4334 
4335  & trim(adjustl(pos_array(4))) // ')'
4336 
4337  end if
4338  deallocate(mask_array, judge, judge_rev)
4339 
4340 
4341 
4342 
4343  if (err_flag) then
4344  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4345  write(*,*) ''
4346  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4347  write(*,*) ' is NOT EQUAL to'
4348  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4349 
4350  call abortprogram('')
4351  else
4352  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4353  end if
4354 
4355 
4356  end subroutine dctestassertequaldouble4
4357 
4358 
4359  subroutine dctestassertequaldouble5(message, answer, check)
4360  use sysdep, only: abortprogram
4361  use dc_types, only: string, token
4362  implicit none
4363  character(*), intent(in):: message
4364  real(DP), intent(in):: answer(:,:,:,:,:)
4365  real(DP), intent(in):: check(:,:,:,:,:)
4366  logical:: err_flag
4367  character(STRING):: pos_str
4368  real(DP):: wrong, right
4369 
4370  integer:: answer_shape(5), check_shape(5), pos(5)
4371  logical:: consist_shape(5)
4372  character(TOKEN):: pos_array(5)
4373  integer, allocatable:: mask_array(:,:,:,:,:)
4374  logical, allocatable:: judge(:,:,:,:,:)
4375  logical, allocatable:: judge_rev(:,:,:,:,:)
4376 
4377 
4378 
4379 
4380  continue
4381  err_flag = .false.
4382 
4383 
4384  answer_shape = shape(answer)
4385  check_shape = shape(check)
4386 
4387  consist_shape = answer_shape == check_shape
4388 
4389  if (.not. all(consist_shape)) then
4390  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4391  write(*,*) ''
4392  write(*,*) ' shape of check is (', check_shape, ')'
4393  write(*,*) ' is INCORRECT'
4394  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4395 
4396  call abortprogram('')
4397  end if
4398 
4399 
4400  allocate( mask_array( &
4401  & answer_shape(1), &
4402 
4403  & answer_shape(2), &
4404 
4405  & answer_shape(3), &
4406 
4407  & answer_shape(4), &
4408 
4409  & answer_shape(5) ) &
4410  & )
4411 
4412  allocate( judge( &
4413  & answer_shape(1), &
4414 
4415  & answer_shape(2), &
4416 
4417  & answer_shape(3), &
4418 
4419  & answer_shape(4), &
4420 
4421  & answer_shape(5) ) &
4422  & )
4423 
4424  allocate( judge_rev( &
4425  & answer_shape(1), &
4426 
4427  & answer_shape(2), &
4428 
4429  & answer_shape(3), &
4430 
4431  & answer_shape(4), &
4432 
4433  & answer_shape(5) ) &
4434  & )
4435 
4436 
4437  judge = answer == check
4438 
4439 
4440 
4441  judge_rev = .not. judge
4442  err_flag = any(judge_rev)
4443  mask_array = 1
4444  pos = maxloc(mask_array, judge_rev)
4445 
4446  if (err_flag) then
4447 
4448  wrong = check( &
4449  & pos(1), &
4450 
4451  & pos(2), &
4452 
4453  & pos(3), &
4454 
4455  & pos(4), &
4456 
4457  & pos(5) )
4458 
4459  right = answer( &
4460  & pos(1), &
4461 
4462  & pos(2), &
4463 
4464  & pos(3), &
4465 
4466  & pos(4), &
4467 
4468  & pos(5) )
4469 
4470  write(unit=pos_array(1), fmt="(i20)") pos(1)
4471 
4472  write(unit=pos_array(2), fmt="(i20)") pos(2)
4473 
4474  write(unit=pos_array(3), fmt="(i20)") pos(3)
4475 
4476  write(unit=pos_array(4), fmt="(i20)") pos(4)
4477 
4478  write(unit=pos_array(5), fmt="(i20)") pos(5)
4479 
4480 
4481  pos_str = '(' // &
4482  & trim(adjustl(pos_array(1))) // ',' // &
4483 
4484  & trim(adjustl(pos_array(2))) // ',' // &
4485 
4486  & trim(adjustl(pos_array(3))) // ',' // &
4487 
4488  & trim(adjustl(pos_array(4))) // ',' // &
4489 
4490  & trim(adjustl(pos_array(5))) // ')'
4491 
4492  end if
4493  deallocate(mask_array, judge, judge_rev)
4494 
4495 
4496 
4497 
4498  if (err_flag) then
4499  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4500  write(*,*) ''
4501  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4502  write(*,*) ' is NOT EQUAL to'
4503  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4504 
4505  call abortprogram('')
4506  else
4507  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4508  end if
4509 
4510 
4511  end subroutine dctestassertequaldouble5
4512 
4513 
4514  subroutine dctestassertequaldouble6(message, answer, check)
4515  use sysdep, only: abortprogram
4516  use dc_types, only: string, token
4517  implicit none
4518  character(*), intent(in):: message
4519  real(DP), intent(in):: answer(:,:,:,:,:,:)
4520  real(DP), intent(in):: check(:,:,:,:,:,:)
4521  logical:: err_flag
4522  character(STRING):: pos_str
4523  real(DP):: wrong, right
4524 
4525  integer:: answer_shape(6), check_shape(6), pos(6)
4526  logical:: consist_shape(6)
4527  character(TOKEN):: pos_array(6)
4528  integer, allocatable:: mask_array(:,:,:,:,:,:)
4529  logical, allocatable:: judge(:,:,:,:,:,:)
4530  logical, allocatable:: judge_rev(:,:,:,:,:,:)
4531 
4532 
4533 
4534 
4535  continue
4536  err_flag = .false.
4537 
4538 
4539  answer_shape = shape(answer)
4540  check_shape = shape(check)
4541 
4542  consist_shape = answer_shape == check_shape
4543 
4544  if (.not. all(consist_shape)) then
4545  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4546  write(*,*) ''
4547  write(*,*) ' shape of check is (', check_shape, ')'
4548  write(*,*) ' is INCORRECT'
4549  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4550 
4551  call abortprogram('')
4552  end if
4553 
4554 
4555  allocate( mask_array( &
4556  & answer_shape(1), &
4557 
4558  & answer_shape(2), &
4559 
4560  & answer_shape(3), &
4561 
4562  & answer_shape(4), &
4563 
4564  & answer_shape(5), &
4565 
4566  & answer_shape(6) ) &
4567  & )
4568 
4569  allocate( judge( &
4570  & answer_shape(1), &
4571 
4572  & answer_shape(2), &
4573 
4574  & answer_shape(3), &
4575 
4576  & answer_shape(4), &
4577 
4578  & answer_shape(5), &
4579 
4580  & answer_shape(6) ) &
4581  & )
4582 
4583  allocate( judge_rev( &
4584  & answer_shape(1), &
4585 
4586  & answer_shape(2), &
4587 
4588  & answer_shape(3), &
4589 
4590  & answer_shape(4), &
4591 
4592  & answer_shape(5), &
4593 
4594  & answer_shape(6) ) &
4595  & )
4596 
4597 
4598  judge = answer == check
4599 
4600 
4601 
4602  judge_rev = .not. judge
4603  err_flag = any(judge_rev)
4604  mask_array = 1
4605  pos = maxloc(mask_array, judge_rev)
4606 
4607  if (err_flag) then
4608 
4609  wrong = check( &
4610  & pos(1), &
4611 
4612  & pos(2), &
4613 
4614  & pos(3), &
4615 
4616  & pos(4), &
4617 
4618  & pos(5), &
4619 
4620  & pos(6) )
4621 
4622  right = answer( &
4623  & pos(1), &
4624 
4625  & pos(2), &
4626 
4627  & pos(3), &
4628 
4629  & pos(4), &
4630 
4631  & pos(5), &
4632 
4633  & pos(6) )
4634 
4635  write(unit=pos_array(1), fmt="(i20)") pos(1)
4636 
4637  write(unit=pos_array(2), fmt="(i20)") pos(2)
4638 
4639  write(unit=pos_array(3), fmt="(i20)") pos(3)
4640 
4641  write(unit=pos_array(4), fmt="(i20)") pos(4)
4642 
4643  write(unit=pos_array(5), fmt="(i20)") pos(5)
4644 
4645  write(unit=pos_array(6), fmt="(i20)") pos(6)
4646 
4647 
4648  pos_str = '(' // &
4649  & trim(adjustl(pos_array(1))) // ',' // &
4650 
4651  & trim(adjustl(pos_array(2))) // ',' // &
4652 
4653  & trim(adjustl(pos_array(3))) // ',' // &
4654 
4655  & trim(adjustl(pos_array(4))) // ',' // &
4656 
4657  & trim(adjustl(pos_array(5))) // ',' // &
4658 
4659  & trim(adjustl(pos_array(6))) // ')'
4660 
4661  end if
4662  deallocate(mask_array, judge, judge_rev)
4663 
4664 
4665 
4666 
4667  if (err_flag) then
4668  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4669  write(*,*) ''
4670  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4671  write(*,*) ' is NOT EQUAL to'
4672  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4673 
4674  call abortprogram('')
4675  else
4676  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4677  end if
4678 
4679 
4680  end subroutine dctestassertequaldouble6
4681 
4682 
4683  subroutine dctestassertequaldouble7(message, answer, check)
4684  use sysdep, only: abortprogram
4685  use dc_types, only: string, token
4686  implicit none
4687  character(*), intent(in):: message
4688  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
4689  real(DP), intent(in):: check(:,:,:,:,:,:,:)
4690  logical:: err_flag
4691  character(STRING):: pos_str
4692  real(DP):: wrong, right
4693 
4694  integer:: answer_shape(7), check_shape(7), pos(7)
4695  logical:: consist_shape(7)
4696  character(TOKEN):: pos_array(7)
4697  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
4698  logical, allocatable:: judge(:,:,:,:,:,:,:)
4699  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
4700 
4701 
4702 
4703 
4704  continue
4705  err_flag = .false.
4706 
4707 
4708  answer_shape = shape(answer)
4709  check_shape = shape(check)
4710 
4711  consist_shape = answer_shape == check_shape
4712 
4713  if (.not. all(consist_shape)) then
4714  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4715  write(*,*) ''
4716  write(*,*) ' shape of check is (', check_shape, ')'
4717  write(*,*) ' is INCORRECT'
4718  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4719 
4720  call abortprogram('')
4721  end if
4722 
4723 
4724  allocate( mask_array( &
4725  & answer_shape(1), &
4726 
4727  & answer_shape(2), &
4728 
4729  & answer_shape(3), &
4730 
4731  & answer_shape(4), &
4732 
4733  & answer_shape(5), &
4734 
4735  & answer_shape(6), &
4736 
4737  & answer_shape(7) ) &
4738  & )
4739 
4740  allocate( judge( &
4741  & answer_shape(1), &
4742 
4743  & answer_shape(2), &
4744 
4745  & answer_shape(3), &
4746 
4747  & answer_shape(4), &
4748 
4749  & answer_shape(5), &
4750 
4751  & answer_shape(6), &
4752 
4753  & answer_shape(7) ) &
4754  & )
4755 
4756  allocate( judge_rev( &
4757  & answer_shape(1), &
4758 
4759  & answer_shape(2), &
4760 
4761  & answer_shape(3), &
4762 
4763  & answer_shape(4), &
4764 
4765  & answer_shape(5), &
4766 
4767  & answer_shape(6), &
4768 
4769  & answer_shape(7) ) &
4770  & )
4771 
4772 
4773  judge = answer == check
4774 
4775 
4776 
4777  judge_rev = .not. judge
4778  err_flag = any(judge_rev)
4779  mask_array = 1
4780  pos = maxloc(mask_array, judge_rev)
4781 
4782  if (err_flag) then
4783 
4784  wrong = check( &
4785  & pos(1), &
4786 
4787  & pos(2), &
4788 
4789  & pos(3), &
4790 
4791  & pos(4), &
4792 
4793  & pos(5), &
4794 
4795  & pos(6), &
4796 
4797  & pos(7) )
4798 
4799  right = answer( &
4800  & pos(1), &
4801 
4802  & pos(2), &
4803 
4804  & pos(3), &
4805 
4806  & pos(4), &
4807 
4808  & pos(5), &
4809 
4810  & pos(6), &
4811 
4812  & pos(7) )
4813 
4814  write(unit=pos_array(1), fmt="(i20)") pos(1)
4815 
4816  write(unit=pos_array(2), fmt="(i20)") pos(2)
4817 
4818  write(unit=pos_array(3), fmt="(i20)") pos(3)
4819 
4820  write(unit=pos_array(4), fmt="(i20)") pos(4)
4821 
4822  write(unit=pos_array(5), fmt="(i20)") pos(5)
4823 
4824  write(unit=pos_array(6), fmt="(i20)") pos(6)
4825 
4826  write(unit=pos_array(7), fmt="(i20)") pos(7)
4827 
4828 
4829  pos_str = '(' // &
4830  & trim(adjustl(pos_array(1))) // ',' // &
4831 
4832  & trim(adjustl(pos_array(2))) // ',' // &
4833 
4834  & trim(adjustl(pos_array(3))) // ',' // &
4835 
4836  & trim(adjustl(pos_array(4))) // ',' // &
4837 
4838  & trim(adjustl(pos_array(5))) // ',' // &
4839 
4840  & trim(adjustl(pos_array(6))) // ',' // &
4841 
4842  & trim(adjustl(pos_array(7))) // ')'
4843 
4844  end if
4845  deallocate(mask_array, judge, judge_rev)
4846 
4847 
4848 
4849 
4850  if (err_flag) then
4851  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4852  write(*,*) ''
4853  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4854  write(*,*) ' is NOT EQUAL to'
4855  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4856 
4857  call abortprogram('')
4858  else
4859  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4860  end if
4861 
4862 
4863  end subroutine dctestassertequaldouble7
4864 
4865  subroutine dctestassertequallogical0(message, answer, check)
4866  use dc_types, only: string
4867  implicit none
4868  character(*), intent(in):: message
4869  logical, intent(in):: answer
4870  logical, intent(in):: check
4871 
4872  character(STRING):: answer_str
4873  character(STRING):: check_str
4874 
4875 
4876 
4877  continue
4878 
4879 
4880  if (answer) then
4881  answer_str = ".true."
4882  else
4883  answer_str = ".false."
4884  end if
4885 
4886  if (check) then
4887  check_str = ".true."
4888  else
4889  check_str = ".false."
4890  end if
4891 
4892 
4893 
4894  call dctestassertequalchar0(message, answer_str, check_str)
4895 
4896 
4897 
4898  end subroutine dctestassertequallogical0
4899  subroutine dctestassertequallogical1(message, answer, check)
4900  use dc_types, only: string
4901  implicit none
4902  character(*), intent(in):: message
4903  logical, intent(in):: answer(:)
4904  logical, intent(in):: check(:)
4905 
4906  integer:: answer_shape(1), check_shape(1), i
4907  logical, allocatable:: answer_tmp(:), check_tmp(:)
4908  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4909  character(STRING), allocatable:: answer_str(:)
4910  character(STRING), allocatable:: check_str(:)
4911 
4912 
4913 
4914  continue
4915 
4916 
4917  allocate(answer_tmp(size(answer)))
4918  allocate(check_tmp(size(check)))
4919  allocate(answer_str_tmp(size(answer)))
4920  allocate(check_str_tmp(size(check)))
4921  answer_tmp = pack(answer, .true.)
4922  check_tmp = pack(check, .true.)
4923 
4924  do i = 1, size(answer_tmp)
4925  if (answer_tmp(i)) then
4926  answer_str_tmp(i) = '.true.'
4927  else
4928  answer_str_tmp(i) = '.false.'
4929  end if
4930  end do
4931 
4932  do i = 1, size(check_tmp)
4933  if (check_tmp(i)) then
4934  check_str_tmp(i) = '.true.'
4935  else
4936  check_str_tmp(i) = '.false.'
4937  end if
4938  end do
4939 
4940  answer_shape = shape(answer)
4941  check_shape = shape(check)
4942 
4943  allocate( answer_str( &
4944 
4945  & answer_shape(1) ) &
4946  & )
4947 
4948  allocate( check_str( &
4949 
4950  & check_shape(1) ) &
4951  & )
4952 
4953  answer_str = reshape(answer_str_tmp, answer_shape)
4954  check_str = reshape(check_str_tmp, check_shape)
4955 
4956 
4957 
4958  call dctestassertequalchar1(message, answer_str, check_str)
4959 
4960  deallocate(answer_str, answer_tmp, answer_str_tmp)
4961  deallocate(check_str, check_tmp, check_str_tmp)
4962 
4963 
4964  end subroutine dctestassertequallogical1
4965  subroutine dctestassertequallogical2(message, answer, check)
4966  use dc_types, only: string
4967  implicit none
4968  character(*), intent(in):: message
4969  logical, intent(in):: answer(:,:)
4970  logical, intent(in):: check(:,:)
4971 
4972  integer:: answer_shape(2), check_shape(2), i
4973  logical, allocatable:: answer_tmp(:), check_tmp(:)
4974  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4975  character(STRING), allocatable:: answer_str(:,:)
4976  character(STRING), allocatable:: check_str(:,:)
4977 
4978 
4979 
4980  continue
4981 
4982 
4983  allocate(answer_tmp(size(answer)))
4984  allocate(check_tmp(size(check)))
4985  allocate(answer_str_tmp(size(answer)))
4986  allocate(check_str_tmp(size(check)))
4987  answer_tmp = pack(answer, .true.)
4988  check_tmp = pack(check, .true.)
4989 
4990  do i = 1, size(answer_tmp)
4991  if (answer_tmp(i)) then
4992  answer_str_tmp(i) = '.true.'
4993  else
4994  answer_str_tmp(i) = '.false.'
4995  end if
4996  end do
4997 
4998  do i = 1, size(check_tmp)
4999  if (check_tmp(i)) then
5000  check_str_tmp(i) = '.true.'
5001  else
5002  check_str_tmp(i) = '.false.'
5003  end if
5004  end do
5005 
5006  answer_shape = shape(answer)
5007  check_shape = shape(check)
5008 
5009  allocate( answer_str( &
5010  & answer_shape(1), &
5011 
5012  & answer_shape(2) ) &
5013  & )
5014 
5015  allocate( check_str( &
5016  & check_shape(1), &
5017 
5018  & check_shape(2) ) &
5019  & )
5020 
5021  answer_str = reshape(answer_str_tmp, answer_shape)
5022  check_str = reshape(check_str_tmp, check_shape)
5023 
5024 
5025 
5026  call dctestassertequalchar2(message, answer_str, check_str)
5027 
5028  deallocate(answer_str, answer_tmp, answer_str_tmp)
5029  deallocate(check_str, check_tmp, check_str_tmp)
5030 
5031 
5032  end subroutine dctestassertequallogical2
5033  subroutine dctestassertequallogical3(message, answer, check)
5034  use dc_types, only: string
5035  implicit none
5036  character(*), intent(in):: message
5037  logical, intent(in):: answer(:,:,:)
5038  logical, intent(in):: check(:,:,:)
5039 
5040  integer:: answer_shape(3), check_shape(3), i
5041  logical, allocatable:: answer_tmp(:), check_tmp(:)
5042  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5043  character(STRING), allocatable:: answer_str(:,:,:)
5044  character(STRING), allocatable:: check_str(:,:,:)
5045 
5046 
5047 
5048  continue
5049 
5050 
5051  allocate(answer_tmp(size(answer)))
5052  allocate(check_tmp(size(check)))
5053  allocate(answer_str_tmp(size(answer)))
5054  allocate(check_str_tmp(size(check)))
5055  answer_tmp = pack(answer, .true.)
5056  check_tmp = pack(check, .true.)
5057 
5058  do i = 1, size(answer_tmp)
5059  if (answer_tmp(i)) then
5060  answer_str_tmp(i) = '.true.'
5061  else
5062  answer_str_tmp(i) = '.false.'
5063  end if
5064  end do
5065 
5066  do i = 1, size(check_tmp)
5067  if (check_tmp(i)) then
5068  check_str_tmp(i) = '.true.'
5069  else
5070  check_str_tmp(i) = '.false.'
5071  end if
5072  end do
5073 
5074  answer_shape = shape(answer)
5075  check_shape = shape(check)
5076 
5077  allocate( answer_str( &
5078  & answer_shape(1), &
5079 
5080  & answer_shape(2), &
5081 
5082  & answer_shape(3) ) &
5083  & )
5084 
5085  allocate( check_str( &
5086  & check_shape(1), &
5087 
5088  & check_shape(2), &
5089 
5090  & check_shape(3) ) &
5091  & )
5092 
5093  answer_str = reshape(answer_str_tmp, answer_shape)
5094  check_str = reshape(check_str_tmp, check_shape)
5095 
5096 
5097 
5098  call dctestassertequalchar3(message, answer_str, check_str)
5099 
5100  deallocate(answer_str, answer_tmp, answer_str_tmp)
5101  deallocate(check_str, check_tmp, check_str_tmp)
5102 
5103 
5104  end subroutine dctestassertequallogical3
5105  subroutine dctestassertequallogical4(message, answer, check)
5106  use dc_types, only: string
5107  implicit none
5108  character(*), intent(in):: message
5109  logical, intent(in):: answer(:,:,:,:)
5110  logical, intent(in):: check(:,:,:,:)
5111 
5112  integer:: answer_shape(4), check_shape(4), i
5113  logical, allocatable:: answer_tmp(:), check_tmp(:)
5114  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5115  character(STRING), allocatable:: answer_str(:,:,:,:)
5116  character(STRING), allocatable:: check_str(:,:,:,:)
5117 
5118 
5119 
5120  continue
5121 
5122 
5123  allocate(answer_tmp(size(answer)))
5124  allocate(check_tmp(size(check)))
5125  allocate(answer_str_tmp(size(answer)))
5126  allocate(check_str_tmp(size(check)))
5127  answer_tmp = pack(answer, .true.)
5128  check_tmp = pack(check, .true.)
5129 
5130  do i = 1, size(answer_tmp)
5131  if (answer_tmp(i)) then
5132  answer_str_tmp(i) = '.true.'
5133  else
5134  answer_str_tmp(i) = '.false.'
5135  end if
5136  end do
5137 
5138  do i = 1, size(check_tmp)
5139  if (check_tmp(i)) then
5140  check_str_tmp(i) = '.true.'
5141  else
5142  check_str_tmp(i) = '.false.'
5143  end if
5144  end do
5145 
5146  answer_shape = shape(answer)
5147  check_shape = shape(check)
5148 
5149  allocate( answer_str( &
5150  & answer_shape(1), &
5151 
5152  & answer_shape(2), &
5153 
5154  & answer_shape(3), &
5155 
5156  & answer_shape(4) ) &
5157  & )
5158 
5159  allocate( check_str( &
5160  & check_shape(1), &
5161 
5162  & check_shape(2), &
5163 
5164  & check_shape(3), &
5165 
5166  & check_shape(4) ) &
5167  & )
5168 
5169  answer_str = reshape(answer_str_tmp, answer_shape)
5170  check_str = reshape(check_str_tmp, check_shape)
5171 
5172 
5173 
5174  call dctestassertequalchar4(message, answer_str, check_str)
5175 
5176  deallocate(answer_str, answer_tmp, answer_str_tmp)
5177  deallocate(check_str, check_tmp, check_str_tmp)
5178 
5179 
5180  end subroutine dctestassertequallogical4
5181  subroutine dctestassertequallogical5(message, answer, check)
5182  use dc_types, only: string
5183  implicit none
5184  character(*), intent(in):: message
5185  logical, intent(in):: answer(:,:,:,:,:)
5186  logical, intent(in):: check(:,:,:,:,:)
5187 
5188  integer:: answer_shape(5), check_shape(5), i
5189  logical, allocatable:: answer_tmp(:), check_tmp(:)
5190  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5191  character(STRING), allocatable:: answer_str(:,:,:,:,:)
5192  character(STRING), allocatable:: check_str(:,:,:,:,:)
5193 
5194 
5195 
5196  continue
5197 
5198 
5199  allocate(answer_tmp(size(answer)))
5200  allocate(check_tmp(size(check)))
5201  allocate(answer_str_tmp(size(answer)))
5202  allocate(check_str_tmp(size(check)))
5203  answer_tmp = pack(answer, .true.)
5204  check_tmp = pack(check, .true.)
5205 
5206  do i = 1, size(answer_tmp)
5207  if (answer_tmp(i)) then
5208  answer_str_tmp(i) = '.true.'
5209  else
5210  answer_str_tmp(i) = '.false.'
5211  end if
5212  end do
5213 
5214  do i = 1, size(check_tmp)
5215  if (check_tmp(i)) then
5216  check_str_tmp(i) = '.true.'
5217  else
5218  check_str_tmp(i) = '.false.'
5219  end if
5220  end do
5221 
5222  answer_shape = shape(answer)
5223  check_shape = shape(check)
5224 
5225  allocate( answer_str( &
5226  & answer_shape(1), &
5227 
5228  & answer_shape(2), &
5229 
5230  & answer_shape(3), &
5231 
5232  & answer_shape(4), &
5233 
5234  & answer_shape(5) ) &
5235  & )
5236 
5237  allocate( check_str( &
5238  & check_shape(1), &
5239 
5240  & check_shape(2), &
5241 
5242  & check_shape(3), &
5243 
5244  & check_shape(4), &
5245 
5246  & check_shape(5) ) &
5247  & )
5248 
5249  answer_str = reshape(answer_str_tmp, answer_shape)
5250  check_str = reshape(check_str_tmp, check_shape)
5251 
5252 
5253 
5254  call dctestassertequalchar5(message, answer_str, check_str)
5255 
5256  deallocate(answer_str, answer_tmp, answer_str_tmp)
5257  deallocate(check_str, check_tmp, check_str_tmp)
5258 
5259 
5260  end subroutine dctestassertequallogical5
5261  subroutine dctestassertequallogical6(message, answer, check)
5262  use dc_types, only: string
5263  implicit none
5264  character(*), intent(in):: message
5265  logical, intent(in):: answer(:,:,:,:,:,:)
5266  logical, intent(in):: check(:,:,:,:,:,:)
5267 
5268  integer:: answer_shape(6), check_shape(6), i
5269  logical, allocatable:: answer_tmp(:), check_tmp(:)
5270  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5271  character(STRING), allocatable:: answer_str(:,:,:,:,:,:)
5272  character(STRING), allocatable:: check_str(:,:,:,:,:,:)
5273 
5274 
5275 
5276  continue
5277 
5278 
5279  allocate(answer_tmp(size(answer)))
5280  allocate(check_tmp(size(check)))
5281  allocate(answer_str_tmp(size(answer)))
5282  allocate(check_str_tmp(size(check)))
5283  answer_tmp = pack(answer, .true.)
5284  check_tmp = pack(check, .true.)
5285 
5286  do i = 1, size(answer_tmp)
5287  if (answer_tmp(i)) then
5288  answer_str_tmp(i) = '.true.'
5289  else
5290  answer_str_tmp(i) = '.false.'
5291  end if
5292  end do
5293 
5294  do i = 1, size(check_tmp)
5295  if (check_tmp(i)) then
5296  check_str_tmp(i) = '.true.'
5297  else
5298  check_str_tmp(i) = '.false.'
5299  end if
5300  end do
5301 
5302  answer_shape = shape(answer)
5303  check_shape = shape(check)
5304 
5305  allocate( answer_str( &
5306  & answer_shape(1), &
5307 
5308  & answer_shape(2), &
5309 
5310  & answer_shape(3), &
5311 
5312  & answer_shape(4), &
5313 
5314  & answer_shape(5), &
5315 
5316  & answer_shape(6) ) &
5317  & )
5318 
5319  allocate( check_str( &
5320  & check_shape(1), &
5321 
5322  & check_shape(2), &
5323 
5324  & check_shape(3), &
5325 
5326  & check_shape(4), &
5327 
5328  & check_shape(5), &
5329 
5330  & check_shape(6) ) &
5331  & )
5332 
5333  answer_str = reshape(answer_str_tmp, answer_shape)
5334  check_str = reshape(check_str_tmp, check_shape)
5335 
5336 
5337 
5338  call dctestassertequalchar6(message, answer_str, check_str)
5339 
5340  deallocate(answer_str, answer_tmp, answer_str_tmp)
5341  deallocate(check_str, check_tmp, check_str_tmp)
5342 
5343 
5344  end subroutine dctestassertequallogical6
5345  subroutine dctestassertequallogical7(message, answer, check)
5346  use dc_types, only: string
5347  implicit none
5348  character(*), intent(in):: message
5349  logical, intent(in):: answer(:,:,:,:,:,:,:)
5350  logical, intent(in):: check(:,:,:,:,:,:,:)
5351 
5352  integer:: answer_shape(7), check_shape(7), i
5353  logical, allocatable:: answer_tmp(:), check_tmp(:)
5354  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5355  character(STRING), allocatable:: answer_str(:,:,:,:,:,:,:)
5356  character(STRING), allocatable:: check_str(:,:,:,:,:,:,:)
5357 
5358 
5359 
5360  continue
5361 
5362 
5363  allocate(answer_tmp(size(answer)))
5364  allocate(check_tmp(size(check)))
5365  allocate(answer_str_tmp(size(answer)))
5366  allocate(check_str_tmp(size(check)))
5367  answer_tmp = pack(answer, .true.)
5368  check_tmp = pack(check, .true.)
5369 
5370  do i = 1, size(answer_tmp)
5371  if (answer_tmp(i)) then
5372  answer_str_tmp(i) = '.true.'
5373  else
5374  answer_str_tmp(i) = '.false.'
5375  end if
5376  end do
5377 
5378  do i = 1, size(check_tmp)
5379  if (check_tmp(i)) then
5380  check_str_tmp(i) = '.true.'
5381  else
5382  check_str_tmp(i) = '.false.'
5383  end if
5384  end do
5385 
5386  answer_shape = shape(answer)
5387  check_shape = shape(check)
5388 
5389  allocate( answer_str( &
5390  & answer_shape(1), &
5391 
5392  & answer_shape(2), &
5393 
5394  & answer_shape(3), &
5395 
5396  & answer_shape(4), &
5397 
5398  & answer_shape(5), &
5399 
5400  & answer_shape(6), &
5401 
5402  & answer_shape(7) ) &
5403  & )
5404 
5405  allocate( check_str( &
5406  & check_shape(1), &
5407 
5408  & check_shape(2), &
5409 
5410  & check_shape(3), &
5411 
5412  & check_shape(4), &
5413 
5414  & check_shape(5), &
5415 
5416  & check_shape(6), &
5417 
5418  & check_shape(7) ) &
5419  & )
5420 
5421  answer_str = reshape(answer_str_tmp, answer_shape)
5422  check_str = reshape(check_str_tmp, check_shape)
5423 
5424 
5425 
5426  call dctestassertequalchar7(message, answer_str, check_str)
5427 
5428  deallocate(answer_str, answer_tmp, answer_str_tmp)
5429  deallocate(check_str, check_tmp, check_str_tmp)
5430 
5431 
5432  end subroutine dctestassertequallogical7
5433 
5434  subroutine dctestassertequalreal0digits( &
5435  & message, answer, check, significant_digits, ignore_digits )
5436  use sysdep, only: abortprogram
5437  use dc_types, only: string, token
5438  implicit none
5439  character(*), intent(in):: message
5440  real, intent(in):: answer
5441  real, intent(in):: check
5442  integer, intent(in):: significant_digits
5443  integer, intent(in):: ignore_digits
5444  logical:: err_flag
5445  character(STRING):: pos_str
5446  real:: wrong, right_max, right_min
5447  character(STRING):: pos_str_space
5448  integer:: pos_str_len
5449  real:: right_tmp
5450 
5451  real:: answer_max
5452  real:: answer_min
5453 
5454  continue
5455  err_flag = .false.
5456 
5457  if ( significant_digits < 1 ) then
5458  write(*,*) ' *** Error [AssertEQ] *** '
5459  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5460  call abortprogram('')
5461  end if
5462 
5463  if ( answer < 0.0 .and. check < 0.0 ) then
5464  answer_max = &
5465  & answer &
5466  & * ( 1.0 &
5467  & - 0.1 ** significant_digits ) &
5468  & + 0.1 ** (- ignore_digits)
5469 
5470  answer_min = &
5471  & answer &
5472  & * ( 1.0 &
5473  & + 0.1 ** significant_digits ) &
5474  & - 0.1 ** (- ignore_digits)
5475  else
5476 
5477  answer_max = &
5478  & answer &
5479  & * ( 1.0 &
5480  & + 0.1 ** significant_digits ) &
5481  & + 0.1 ** (- ignore_digits)
5482 
5483  answer_min = &
5484  & answer &
5485  & * ( 1.0 &
5486  & - 0.1 ** significant_digits ) &
5487  & - 0.1 ** (- ignore_digits)
5488  end if
5489 
5490  wrong = check
5491  right_max = answer_max
5492  right_min = answer_min
5493  if ( right_max < right_min ) then
5494  right_tmp = right_max
5495  right_max = right_min
5496  right_min = right_tmp
5497  end if
5498 
5499  err_flag = .not. (answer_max > check .and. check > answer_min)
5500 
5501  pos_str = ''
5502 
5503 
5504 
5505  if (err_flag) then
5506  pos_str_space = ''
5507  pos_str_len = len_trim(pos_str)
5508 
5509  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5510  write(*,*) ''
5511  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5512  write(*,*) ' is NOT EQUAL to'
5513  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5514  & // ' ', right_min, ' < '
5515  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5516 
5517  call abortprogram('')
5518  else
5519  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5520  end if
5521 
5522 
5523  end subroutine dctestassertequalreal0digits
5524 
5525 
5526  subroutine dctestassertequalreal1digits( &
5527  & message, answer, check, significant_digits, ignore_digits )
5528  use sysdep, only: abortprogram
5529  use dc_types, only: string, token
5530  implicit none
5531  character(*), intent(in):: message
5532  real, intent(in):: answer(:)
5533  real, intent(in):: check(:)
5534  integer, intent(in):: significant_digits
5535  integer, intent(in):: ignore_digits
5536  logical:: err_flag
5537  character(STRING):: pos_str
5538  real:: wrong, right_max, right_min
5539  character(STRING):: pos_str_space
5540  integer:: pos_str_len
5541  real:: right_tmp
5542 
5543  integer:: answer_shape(1), check_shape(1), pos(1)
5544  logical:: consist_shape(1)
5545  character(TOKEN):: pos_array(1)
5546  integer, allocatable:: mask_array(:)
5547  logical, allocatable:: judge(:)
5548  logical, allocatable:: judge_rev(:)
5549  logical, allocatable:: answer_negative(:)
5550  logical, allocatable:: check_negative(:)
5551  logical, allocatable:: both_negative(:)
5552  real, allocatable:: answer_max(:)
5553  real, allocatable:: answer_min(:)
5554 
5555  continue
5556  err_flag = .false.
5557 
5558  if ( significant_digits < 1 ) then
5559  write(*,*) ' *** Error [AssertEQ] *** '
5560  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5561  call abortprogram('')
5562  end if
5563 
5564  answer_shape = shape(answer)
5565  check_shape = shape(check)
5566 
5567  consist_shape = answer_shape == check_shape
5568 
5569  if (.not. all(consist_shape)) then
5570  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5571  write(*,*) ''
5572  write(*,*) ' shape of check is (', check_shape, ')'
5573  write(*,*) ' is INCORRECT'
5574  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5575 
5576  call abortprogram('')
5577  end if
5578 
5579 
5580  allocate( mask_array( &
5581 
5582  & answer_shape(1) ) &
5583  & )
5584 
5585  allocate( judge( &
5586 
5587  & answer_shape(1) ) &
5588  & )
5589 
5590  allocate( judge_rev( &
5591 
5592  & answer_shape(1) ) &
5593  & )
5594 
5595  allocate( answer_negative( &
5596 
5597  & answer_shape(1) ) &
5598  & )
5599 
5600  allocate( check_negative( &
5601 
5602  & answer_shape(1) ) &
5603  & )
5604 
5605  allocate( both_negative( &
5606 
5607  & answer_shape(1) ) &
5608  & )
5609 
5610  allocate( answer_max( &
5611 
5612  & answer_shape(1) ) &
5613  & )
5614 
5615  allocate( answer_min( &
5616 
5617  & answer_shape(1) ) &
5618  & )
5619 
5620  answer_negative = answer < 0.0
5621  check_negative = check < 0.0
5622  both_negative = answer_negative .and. check_negative
5623 
5624  where (both_negative)
5625  answer_max = &
5626  & answer &
5627  & * ( 1.0 &
5628  & - 0.1 ** significant_digits ) &
5629  & + 0.1 ** (- ignore_digits)
5630 
5631  answer_min = &
5632  & answer &
5633  & * ( 1.0 &
5634  & + 0.1 ** significant_digits ) &
5635  & - 0.1 ** (- ignore_digits)
5636  elsewhere
5637  answer_max = &
5638  & answer &
5639  & * ( 1.0 &
5640  & + 0.1 ** significant_digits ) &
5641  & + 0.1 ** (- ignore_digits)
5642 
5643  answer_min = &
5644  & answer &
5645  & * ( 1.0 &
5646  & - 0.1 ** significant_digits ) &
5647  & - 0.1 ** (- ignore_digits)
5648  end where
5649 
5650  judge = answer_max > check .and. check > answer_min
5651  judge_rev = .not. judge
5652  err_flag = any(judge_rev)
5653  mask_array = 1
5654  pos = maxloc(mask_array, judge_rev)
5655 
5656  if (err_flag) then
5657 
5658  wrong = check( &
5659 
5660  & pos(1) )
5661 
5662  right_max = answer_max( &
5663 
5664  & pos(1) )
5665 
5666  right_min = answer_min( &
5667 
5668  & pos(1) )
5669 
5670  if ( right_max < right_min ) then
5671  right_tmp = right_max
5672  right_max = right_min
5673  right_min = right_tmp
5674  end if
5675 
5676  write(unit=pos_array(1), fmt="(i20)") pos(1)
5677 
5678 
5679  pos_str = '(' // &
5680 
5681  & trim(adjustl(pos_array(1))) // ')'
5682 
5683  end if
5684  deallocate(mask_array, judge, judge_rev)
5685  deallocate(answer_negative, check_negative, both_negative)
5686  deallocate(answer_max, answer_min)
5687 
5688 
5689 
5690  if (err_flag) then
5691  pos_str_space = ''
5692  pos_str_len = len_trim(pos_str)
5693 
5694  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5695  write(*,*) ''
5696  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5697  write(*,*) ' is NOT EQUAL to'
5698  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5699  & // ' ', right_min, ' < '
5700  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5701 
5702  call abortprogram('')
5703  else
5704  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5705  end if
5706 
5707 
5708  end subroutine dctestassertequalreal1digits
5709 
5710 
5711  subroutine dctestassertequalreal2digits( &
5712  & message, answer, check, significant_digits, ignore_digits )
5713  use sysdep, only: abortprogram
5714  use dc_types, only: string, token
5715  implicit none
5716  character(*), intent(in):: message
5717  real, intent(in):: answer(:,:)
5718  real, intent(in):: check(:,:)
5719  integer, intent(in):: significant_digits
5720  integer, intent(in):: ignore_digits
5721  logical:: err_flag
5722  character(STRING):: pos_str
5723  real:: wrong, right_max, right_min
5724  character(STRING):: pos_str_space
5725  integer:: pos_str_len
5726  real:: right_tmp
5727 
5728  integer:: answer_shape(2), check_shape(2), pos(2)
5729  logical:: consist_shape(2)
5730  character(TOKEN):: pos_array(2)
5731  integer, allocatable:: mask_array(:,:)
5732  logical, allocatable:: judge(:,:)
5733  logical, allocatable:: judge_rev(:,:)
5734  logical, allocatable:: answer_negative(:,:)
5735  logical, allocatable:: check_negative(:,:)
5736  logical, allocatable:: both_negative(:,:)
5737  real, allocatable:: answer_max(:,:)
5738  real, allocatable:: answer_min(:,:)
5739 
5740  continue
5741  err_flag = .false.
5742 
5743  if ( significant_digits < 1 ) then
5744  write(*,*) ' *** Error [AssertEQ] *** '
5745  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5746  call abortprogram('')
5747  end if
5748 
5749  answer_shape = shape(answer)
5750  check_shape = shape(check)
5751 
5752  consist_shape = answer_shape == check_shape
5753 
5754  if (.not. all(consist_shape)) then
5755  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5756  write(*,*) ''
5757  write(*,*) ' shape of check is (', check_shape, ')'
5758  write(*,*) ' is INCORRECT'
5759  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5760 
5761  call abortprogram('')
5762  end if
5763 
5764 
5765  allocate( mask_array( &
5766  & answer_shape(1), &
5767 
5768  & answer_shape(2) ) &
5769  & )
5770 
5771  allocate( judge( &
5772  & answer_shape(1), &
5773 
5774  & answer_shape(2) ) &
5775  & )
5776 
5777  allocate( judge_rev( &
5778  & answer_shape(1), &
5779 
5780  & answer_shape(2) ) &
5781  & )
5782 
5783  allocate( answer_negative( &
5784  & answer_shape(1), &
5785 
5786  & answer_shape(2) ) &
5787  & )
5788 
5789  allocate( check_negative( &
5790  & answer_shape(1), &
5791 
5792  & answer_shape(2) ) &
5793  & )
5794 
5795  allocate( both_negative( &
5796  & answer_shape(1), &
5797 
5798  & answer_shape(2) ) &
5799  & )
5800 
5801  allocate( answer_max( &
5802  & answer_shape(1), &
5803 
5804  & answer_shape(2) ) &
5805  & )
5806 
5807  allocate( answer_min( &
5808  & answer_shape(1), &
5809 
5810  & answer_shape(2) ) &
5811  & )
5812 
5813  answer_negative = answer < 0.0
5814  check_negative = check < 0.0
5815  both_negative = answer_negative .and. check_negative
5816 
5817  where (both_negative)
5818  answer_max = &
5819  & answer &
5820  & * ( 1.0 &
5821  & - 0.1 ** significant_digits ) &
5822  & + 0.1 ** (- ignore_digits)
5823 
5824  answer_min = &
5825  & answer &
5826  & * ( 1.0 &
5827  & + 0.1 ** significant_digits ) &
5828  & - 0.1 ** (- ignore_digits)
5829  elsewhere
5830  answer_max = &
5831  & answer &
5832  & * ( 1.0 &
5833  & + 0.1 ** significant_digits ) &
5834  & + 0.1 ** (- ignore_digits)
5835 
5836  answer_min = &
5837  & answer &
5838  & * ( 1.0 &
5839  & - 0.1 ** significant_digits ) &
5840  & - 0.1 ** (- ignore_digits)
5841  end where
5842 
5843  judge = answer_max > check .and. check > answer_min
5844  judge_rev = .not. judge
5845  err_flag = any(judge_rev)
5846  mask_array = 1
5847  pos = maxloc(mask_array, judge_rev)
5848 
5849  if (err_flag) then
5850 
5851  wrong = check( &
5852  & pos(1), &
5853 
5854  & pos(2) )
5855 
5856  right_max = answer_max( &
5857  & pos(1), &
5858 
5859  & pos(2) )
5860 
5861  right_min = answer_min( &
5862  & pos(1), &
5863 
5864  & pos(2) )
5865 
5866  if ( right_max < right_min ) then
5867  right_tmp = right_max
5868  right_max = right_min
5869  right_min = right_tmp
5870  end if
5871 
5872  write(unit=pos_array(1), fmt="(i20)") pos(1)
5873 
5874  write(unit=pos_array(2), fmt="(i20)") pos(2)
5875 
5876 
5877  pos_str = '(' // &
5878  & trim(adjustl(pos_array(1))) // ',' // &
5879 
5880  & trim(adjustl(pos_array(2))) // ')'
5881 
5882  end if
5883  deallocate(mask_array, judge, judge_rev)
5884  deallocate(answer_negative, check_negative, both_negative)
5885  deallocate(answer_max, answer_min)
5886 
5887 
5888 
5889  if (err_flag) then
5890  pos_str_space = ''
5891  pos_str_len = len_trim(pos_str)
5892 
5893  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5894  write(*,*) ''
5895  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5896  write(*,*) ' is NOT EQUAL to'
5897  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5898  & // ' ', right_min, ' < '
5899  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5900 
5901  call abortprogram('')
5902  else
5903  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5904  end if
5905 
5906 
5907  end subroutine dctestassertequalreal2digits
5908 
5909 
5910  subroutine dctestassertequalreal3digits( &
5911  & message, answer, check, significant_digits, ignore_digits )
5912  use sysdep, only: abortprogram
5913  use dc_types, only: string, token
5914  implicit none
5915  character(*), intent(in):: message
5916  real, intent(in):: answer(:,:,:)
5917  real, intent(in):: check(:,:,:)
5918  integer, intent(in):: significant_digits
5919  integer, intent(in):: ignore_digits
5920  logical:: err_flag
5921  character(STRING):: pos_str
5922  real:: wrong, right_max, right_min
5923  character(STRING):: pos_str_space
5924  integer:: pos_str_len
5925  real:: right_tmp
5926 
5927  integer:: answer_shape(3), check_shape(3), pos(3)
5928  logical:: consist_shape(3)
5929  character(TOKEN):: pos_array(3)
5930  integer, allocatable:: mask_array(:,:,:)
5931  logical, allocatable:: judge(:,:,:)
5932  logical, allocatable:: judge_rev(:,:,:)
5933  logical, allocatable:: answer_negative(:,:,:)
5934  logical, allocatable:: check_negative(:,:,:)
5935  logical, allocatable:: both_negative(:,:,:)
5936  real, allocatable:: answer_max(:,:,:)
5937  real, allocatable:: answer_min(:,:,:)
5938 
5939  continue
5940  err_flag = .false.
5941 
5942  if ( significant_digits < 1 ) then
5943  write(*,*) ' *** Error [AssertEQ] *** '
5944  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5945  call abortprogram('')
5946  end if
5947 
5948  answer_shape = shape(answer)
5949  check_shape = shape(check)
5950 
5951  consist_shape = answer_shape == check_shape
5952 
5953  if (.not. all(consist_shape)) then
5954  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5955  write(*,*) ''
5956  write(*,*) ' shape of check is (', check_shape, ')'
5957  write(*,*) ' is INCORRECT'
5958  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5959 
5960  call abortprogram('')
5961  end if
5962 
5963 
5964  allocate( mask_array( &
5965  & answer_shape(1), &
5966 
5967  & answer_shape(2), &
5968 
5969  & answer_shape(3) ) &
5970  & )
5971 
5972  allocate( judge( &
5973  & answer_shape(1), &
5974 
5975  & answer_shape(2), &
5976 
5977  & answer_shape(3) ) &
5978  & )
5979 
5980  allocate( judge_rev( &
5981  & answer_shape(1), &
5982 
5983  & answer_shape(2), &
5984 
5985  & answer_shape(3) ) &
5986  & )
5987 
5988  allocate( answer_negative( &
5989  & answer_shape(1), &
5990 
5991  & answer_shape(2), &
5992 
5993  & answer_shape(3) ) &
5994  & )
5995 
5996  allocate( check_negative( &
5997  & answer_shape(1), &
5998 
5999  & answer_shape(2), &
6000 
6001  & answer_shape(3) ) &
6002  & )
6003 
6004  allocate( both_negative( &
6005  & answer_shape(1), &
6006 
6007  & answer_shape(2), &
6008 
6009  & answer_shape(3) ) &
6010  & )
6011 
6012  allocate( answer_max( &
6013  & answer_shape(1), &
6014 
6015  & answer_shape(2), &
6016 
6017  & answer_shape(3) ) &
6018  & )
6019 
6020  allocate( answer_min( &
6021  & answer_shape(1), &
6022 
6023  & answer_shape(2), &
6024 
6025  & answer_shape(3) ) &
6026  & )
6027 
6028  answer_negative = answer < 0.0
6029  check_negative = check < 0.0
6030  both_negative = answer_negative .and. check_negative
6031 
6032  where (both_negative)
6033  answer_max = &
6034  & answer &
6035  & * ( 1.0 &
6036  & - 0.1 ** significant_digits ) &
6037  & + 0.1 ** (- ignore_digits)
6038 
6039  answer_min = &
6040  & answer &
6041  & * ( 1.0 &
6042  & + 0.1 ** significant_digits ) &
6043  & - 0.1 ** (- ignore_digits)
6044  elsewhere
6045  answer_max = &
6046  & answer &
6047  & * ( 1.0 &
6048  & + 0.1 ** significant_digits ) &
6049  & + 0.1 ** (- ignore_digits)
6050 
6051  answer_min = &
6052  & answer &
6053  & * ( 1.0 &
6054  & - 0.1 ** significant_digits ) &
6055  & - 0.1 ** (- ignore_digits)
6056  end where
6057 
6058  judge = answer_max > check .and. check > answer_min
6059  judge_rev = .not. judge
6060  err_flag = any(judge_rev)
6061  mask_array = 1
6062  pos = maxloc(mask_array, judge_rev)
6063 
6064  if (err_flag) then
6065 
6066  wrong = check( &
6067  & pos(1), &
6068 
6069  & pos(2), &
6070 
6071  & pos(3) )
6072 
6073  right_max = answer_max( &
6074  & pos(1), &
6075 
6076  & pos(2), &
6077 
6078  & pos(3) )
6079 
6080  right_min = answer_min( &
6081  & pos(1), &
6082 
6083  & pos(2), &
6084 
6085  & pos(3) )
6086 
6087  if ( right_max < right_min ) then
6088  right_tmp = right_max
6089  right_max = right_min
6090  right_min = right_tmp
6091  end if
6092 
6093  write(unit=pos_array(1), fmt="(i20)") pos(1)
6094 
6095  write(unit=pos_array(2), fmt="(i20)") pos(2)
6096 
6097  write(unit=pos_array(3), fmt="(i20)") pos(3)
6098 
6099 
6100  pos_str = '(' // &
6101  & trim(adjustl(pos_array(1))) // ',' // &
6102 
6103  & trim(adjustl(pos_array(2))) // ',' // &
6104 
6105  & trim(adjustl(pos_array(3))) // ')'
6106 
6107  end if
6108  deallocate(mask_array, judge, judge_rev)
6109  deallocate(answer_negative, check_negative, both_negative)
6110  deallocate(answer_max, answer_min)
6111 
6112 
6113 
6114  if (err_flag) then
6115  pos_str_space = ''
6116  pos_str_len = len_trim(pos_str)
6117 
6118  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6119  write(*,*) ''
6120  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6121  write(*,*) ' is NOT EQUAL to'
6122  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6123  & // ' ', right_min, ' < '
6124  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6125 
6126  call abortprogram('')
6127  else
6128  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6129  end if
6130 
6131 
6132  end subroutine dctestassertequalreal3digits
6133 
6134 
6135  subroutine dctestassertequalreal4digits( &
6136  & message, answer, check, significant_digits, ignore_digits )
6137  use sysdep, only: abortprogram
6138  use dc_types, only: string, token
6139  implicit none
6140  character(*), intent(in):: message
6141  real, intent(in):: answer(:,:,:,:)
6142  real, intent(in):: check(:,:,:,:)
6143  integer, intent(in):: significant_digits
6144  integer, intent(in):: ignore_digits
6145  logical:: err_flag
6146  character(STRING):: pos_str
6147  real:: wrong, right_max, right_min
6148  character(STRING):: pos_str_space
6149  integer:: pos_str_len
6150  real:: right_tmp
6151 
6152  integer:: answer_shape(4), check_shape(4), pos(4)
6153  logical:: consist_shape(4)
6154  character(TOKEN):: pos_array(4)
6155  integer, allocatable:: mask_array(:,:,:,:)
6156  logical, allocatable:: judge(:,:,:,:)
6157  logical, allocatable:: judge_rev(:,:,:,:)
6158  logical, allocatable:: answer_negative(:,:,:,:)
6159  logical, allocatable:: check_negative(:,:,:,:)
6160  logical, allocatable:: both_negative(:,:,:,:)
6161  real, allocatable:: answer_max(:,:,:,:)
6162  real, allocatable:: answer_min(:,:,:,:)
6163 
6164  continue
6165  err_flag = .false.
6166 
6167  if ( significant_digits < 1 ) then
6168  write(*,*) ' *** Error [AssertEQ] *** '
6169  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6170  call abortprogram('')
6171  end if
6172 
6173  answer_shape = shape(answer)
6174  check_shape = shape(check)
6175 
6176  consist_shape = answer_shape == check_shape
6177 
6178  if (.not. all(consist_shape)) then
6179  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6180  write(*,*) ''
6181  write(*,*) ' shape of check is (', check_shape, ')'
6182  write(*,*) ' is INCORRECT'
6183  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6184 
6185  call abortprogram('')
6186  end if
6187 
6188 
6189  allocate( mask_array( &
6190  & answer_shape(1), &
6191 
6192  & answer_shape(2), &
6193 
6194  & answer_shape(3), &
6195 
6196  & answer_shape(4) ) &
6197  & )
6198 
6199  allocate( judge( &
6200  & answer_shape(1), &
6201 
6202  & answer_shape(2), &
6203 
6204  & answer_shape(3), &
6205 
6206  & answer_shape(4) ) &
6207  & )
6208 
6209  allocate( judge_rev( &
6210  & answer_shape(1), &
6211 
6212  & answer_shape(2), &
6213 
6214  & answer_shape(3), &
6215 
6216  & answer_shape(4) ) &
6217  & )
6218 
6219  allocate( answer_negative( &
6220  & answer_shape(1), &
6221 
6222  & answer_shape(2), &
6223 
6224  & answer_shape(3), &
6225 
6226  & answer_shape(4) ) &
6227  & )
6228 
6229  allocate( check_negative( &
6230  & answer_shape(1), &
6231 
6232  & answer_shape(2), &
6233 
6234  & answer_shape(3), &
6235 
6236  & answer_shape(4) ) &
6237  & )
6238 
6239  allocate( both_negative( &
6240  & answer_shape(1), &
6241 
6242  & answer_shape(2), &
6243 
6244  & answer_shape(3), &
6245 
6246  & answer_shape(4) ) &
6247  & )
6248 
6249  allocate( answer_max( &
6250  & answer_shape(1), &
6251 
6252  & answer_shape(2), &
6253 
6254  & answer_shape(3), &
6255 
6256  & answer_shape(4) ) &
6257  & )
6258 
6259  allocate( answer_min( &
6260  & answer_shape(1), &
6261 
6262  & answer_shape(2), &
6263 
6264  & answer_shape(3), &
6265 
6266  & answer_shape(4) ) &
6267  & )
6268 
6269  answer_negative = answer < 0.0
6270  check_negative = check < 0.0
6271  both_negative = answer_negative .and. check_negative
6272 
6273  where (both_negative)
6274  answer_max = &
6275  & answer &
6276  & * ( 1.0 &
6277  & - 0.1 ** significant_digits ) &
6278  & + 0.1 ** (- ignore_digits)
6279 
6280  answer_min = &
6281  & answer &
6282  & * ( 1.0 &
6283  & + 0.1 ** significant_digits ) &
6284  & - 0.1 ** (- ignore_digits)
6285  elsewhere
6286  answer_max = &
6287  & answer &
6288  & * ( 1.0 &
6289  & + 0.1 ** significant_digits ) &
6290  & + 0.1 ** (- ignore_digits)
6291 
6292  answer_min = &
6293  & answer &
6294  & * ( 1.0 &
6295  & - 0.1 ** significant_digits ) &
6296  & - 0.1 ** (- ignore_digits)
6297  end where
6298 
6299  judge = answer_max > check .and. check > answer_min
6300  judge_rev = .not. judge
6301  err_flag = any(judge_rev)
6302  mask_array = 1
6303  pos = maxloc(mask_array, judge_rev)
6304 
6305  if (err_flag) then
6306 
6307  wrong = check( &
6308  & pos(1), &
6309 
6310  & pos(2), &
6311 
6312  & pos(3), &
6313 
6314  & pos(4) )
6315 
6316  right_max = answer_max( &
6317  & pos(1), &
6318 
6319  & pos(2), &
6320 
6321  & pos(3), &
6322 
6323  & pos(4) )
6324 
6325  right_min = answer_min( &
6326  & pos(1), &
6327 
6328  & pos(2), &
6329 
6330  & pos(3), &
6331 
6332  & pos(4) )
6333 
6334  if ( right_max < right_min ) then
6335  right_tmp = right_max
6336  right_max = right_min
6337  right_min = right_tmp
6338  end if
6339 
6340  write(unit=pos_array(1), fmt="(i20)") pos(1)
6341 
6342  write(unit=pos_array(2), fmt="(i20)") pos(2)
6343 
6344  write(unit=pos_array(3), fmt="(i20)") pos(3)
6345 
6346  write(unit=pos_array(4), fmt="(i20)") pos(4)
6347 
6348 
6349  pos_str = '(' // &
6350  & trim(adjustl(pos_array(1))) // ',' // &
6351 
6352  & trim(adjustl(pos_array(2))) // ',' // &
6353 
6354  & trim(adjustl(pos_array(3))) // ',' // &
6355 
6356  & trim(adjustl(pos_array(4))) // ')'
6357 
6358  end if
6359  deallocate(mask_array, judge, judge_rev)
6360  deallocate(answer_negative, check_negative, both_negative)
6361  deallocate(answer_max, answer_min)
6362 
6363 
6364 
6365  if (err_flag) then
6366  pos_str_space = ''
6367  pos_str_len = len_trim(pos_str)
6368 
6369  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6370  write(*,*) ''
6371  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6372  write(*,*) ' is NOT EQUAL to'
6373  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6374  & // ' ', right_min, ' < '
6375  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6376 
6377  call abortprogram('')
6378  else
6379  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6380  end if
6381 
6382 
6383  end subroutine dctestassertequalreal4digits
6384 
6385 
6386  subroutine dctestassertequalreal5digits( &
6387  & message, answer, check, significant_digits, ignore_digits )
6388  use sysdep, only: abortprogram
6389  use dc_types, only: string, token
6390  implicit none
6391  character(*), intent(in):: message
6392  real, intent(in):: answer(:,:,:,:,:)
6393  real, intent(in):: check(:,:,:,:,:)
6394  integer, intent(in):: significant_digits
6395  integer, intent(in):: ignore_digits
6396  logical:: err_flag
6397  character(STRING):: pos_str
6398  real:: wrong, right_max, right_min
6399  character(STRING):: pos_str_space
6400  integer:: pos_str_len
6401  real:: right_tmp
6402 
6403  integer:: answer_shape(5), check_shape(5), pos(5)
6404  logical:: consist_shape(5)
6405  character(TOKEN):: pos_array(5)
6406  integer, allocatable:: mask_array(:,:,:,:,:)
6407  logical, allocatable:: judge(:,:,:,:,:)
6408  logical, allocatable:: judge_rev(:,:,:,:,:)
6409  logical, allocatable:: answer_negative(:,:,:,:,:)
6410  logical, allocatable:: check_negative(:,:,:,:,:)
6411  logical, allocatable:: both_negative(:,:,:,:,:)
6412  real, allocatable:: answer_max(:,:,:,:,:)
6413  real, allocatable:: answer_min(:,:,:,:,:)
6414 
6415  continue
6416  err_flag = .false.
6417 
6418  if ( significant_digits < 1 ) then
6419  write(*,*) ' *** Error [AssertEQ] *** '
6420  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6421  call abortprogram('')
6422  end if
6423 
6424  answer_shape = shape(answer)
6425  check_shape = shape(check)
6426 
6427  consist_shape = answer_shape == check_shape
6428 
6429  if (.not. all(consist_shape)) then
6430  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6431  write(*,*) ''
6432  write(*,*) ' shape of check is (', check_shape, ')'
6433  write(*,*) ' is INCORRECT'
6434  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6435 
6436  call abortprogram('')
6437  end if
6438 
6439 
6440  allocate( mask_array( &
6441  & answer_shape(1), &
6442 
6443  & answer_shape(2), &
6444 
6445  & answer_shape(3), &
6446 
6447  & answer_shape(4), &
6448 
6449  & answer_shape(5) ) &
6450  & )
6451 
6452  allocate( judge( &
6453  & answer_shape(1), &
6454 
6455  & answer_shape(2), &
6456 
6457  & answer_shape(3), &
6458 
6459  & answer_shape(4), &
6460 
6461  & answer_shape(5) ) &
6462  & )
6463 
6464  allocate( judge_rev( &
6465  & answer_shape(1), &
6466 
6467  & answer_shape(2), &
6468 
6469  & answer_shape(3), &
6470 
6471  & answer_shape(4), &
6472 
6473  & answer_shape(5) ) &
6474  & )
6475 
6476  allocate( answer_negative( &
6477  & answer_shape(1), &
6478 
6479  & answer_shape(2), &
6480 
6481  & answer_shape(3), &
6482 
6483  & answer_shape(4), &
6484 
6485  & answer_shape(5) ) &
6486  & )
6487 
6488  allocate( check_negative( &
6489  & answer_shape(1), &
6490 
6491  & answer_shape(2), &
6492 
6493  & answer_shape(3), &
6494 
6495  & answer_shape(4), &
6496 
6497  & answer_shape(5) ) &
6498  & )
6499 
6500  allocate( both_negative( &
6501  & answer_shape(1), &
6502 
6503  & answer_shape(2), &
6504 
6505  & answer_shape(3), &
6506 
6507  & answer_shape(4), &
6508 
6509  & answer_shape(5) ) &
6510  & )
6511 
6512  allocate( answer_max( &
6513  & answer_shape(1), &
6514 
6515  & answer_shape(2), &
6516 
6517  & answer_shape(3), &
6518 
6519  & answer_shape(4), &
6520 
6521  & answer_shape(5) ) &
6522  & )
6523 
6524  allocate( answer_min( &
6525  & answer_shape(1), &
6526 
6527  & answer_shape(2), &
6528 
6529  & answer_shape(3), &
6530 
6531  & answer_shape(4), &
6532 
6533  & answer_shape(5) ) &
6534  & )
6535 
6536  answer_negative = answer < 0.0
6537  check_negative = check < 0.0
6538  both_negative = answer_negative .and. check_negative
6539 
6540  where (both_negative)
6541  answer_max = &
6542  & answer &
6543  & * ( 1.0 &
6544  & - 0.1 ** significant_digits ) &
6545  & + 0.1 ** (- ignore_digits)
6546 
6547  answer_min = &
6548  & answer &
6549  & * ( 1.0 &
6550  & + 0.1 ** significant_digits ) &
6551  & - 0.1 ** (- ignore_digits)
6552  elsewhere
6553  answer_max = &
6554  & answer &
6555  & * ( 1.0 &
6556  & + 0.1 ** significant_digits ) &
6557  & + 0.1 ** (- ignore_digits)
6558 
6559  answer_min = &
6560  & answer &
6561  & * ( 1.0 &
6562  & - 0.1 ** significant_digits ) &
6563  & - 0.1 ** (- ignore_digits)
6564  end where
6565 
6566  judge = answer_max > check .and. check > answer_min
6567  judge_rev = .not. judge
6568  err_flag = any(judge_rev)
6569  mask_array = 1
6570  pos = maxloc(mask_array, judge_rev)
6571 
6572  if (err_flag) then
6573 
6574  wrong = check( &
6575  & pos(1), &
6576 
6577  & pos(2), &
6578 
6579  & pos(3), &
6580 
6581  & pos(4), &
6582 
6583  & pos(5) )
6584 
6585  right_max = answer_max( &
6586  & pos(1), &
6587 
6588  & pos(2), &
6589 
6590  & pos(3), &
6591 
6592  & pos(4), &
6593 
6594  & pos(5) )
6595 
6596  right_min = answer_min( &
6597  & pos(1), &
6598 
6599  & pos(2), &
6600 
6601  & pos(3), &
6602 
6603  & pos(4), &
6604 
6605  & pos(5) )
6606 
6607  if ( right_max < right_min ) then
6608  right_tmp = right_max
6609  right_max = right_min
6610  right_min = right_tmp
6611  end if
6612 
6613  write(unit=pos_array(1), fmt="(i20)") pos(1)
6614 
6615  write(unit=pos_array(2), fmt="(i20)") pos(2)
6616 
6617  write(unit=pos_array(3), fmt="(i20)") pos(3)
6618 
6619  write(unit=pos_array(4), fmt="(i20)") pos(4)
6620 
6621  write(unit=pos_array(5), fmt="(i20)") pos(5)
6622 
6623 
6624  pos_str = '(' // &
6625  & trim(adjustl(pos_array(1))) // ',' // &
6626 
6627  & trim(adjustl(pos_array(2))) // ',' // &
6628 
6629  & trim(adjustl(pos_array(3))) // ',' // &
6630 
6631  & trim(adjustl(pos_array(4))) // ',' // &
6632 
6633  & trim(adjustl(pos_array(5))) // ')'
6634 
6635  end if
6636  deallocate(mask_array, judge, judge_rev)
6637  deallocate(answer_negative, check_negative, both_negative)
6638  deallocate(answer_max, answer_min)
6639 
6640 
6641 
6642  if (err_flag) then
6643  pos_str_space = ''
6644  pos_str_len = len_trim(pos_str)
6645 
6646  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6647  write(*,*) ''
6648  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6649  write(*,*) ' is NOT EQUAL to'
6650  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6651  & // ' ', right_min, ' < '
6652  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6653 
6654  call abortprogram('')
6655  else
6656  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6657  end if
6658 
6659 
6660  end subroutine dctestassertequalreal5digits
6661 
6662 
6663  subroutine dctestassertequalreal6digits( &
6664  & message, answer, check, significant_digits, ignore_digits )
6665  use sysdep, only: abortprogram
6666  use dc_types, only: string, token
6667  implicit none
6668  character(*), intent(in):: message
6669  real, intent(in):: answer(:,:,:,:,:,:)
6670  real, intent(in):: check(:,:,:,:,:,:)
6671  integer, intent(in):: significant_digits
6672  integer, intent(in):: ignore_digits
6673  logical:: err_flag
6674  character(STRING):: pos_str
6675  real:: wrong, right_max, right_min
6676  character(STRING):: pos_str_space
6677  integer:: pos_str_len
6678  real:: right_tmp
6679 
6680  integer:: answer_shape(6), check_shape(6), pos(6)
6681  logical:: consist_shape(6)
6682  character(TOKEN):: pos_array(6)
6683  integer, allocatable:: mask_array(:,:,:,:,:,:)
6684  logical, allocatable:: judge(:,:,:,:,:,:)
6685  logical, allocatable:: judge_rev(:,:,:,:,:,:)
6686  logical, allocatable:: answer_negative(:,:,:,:,:,:)
6687  logical, allocatable:: check_negative(:,:,:,:,:,:)
6688  logical, allocatable:: both_negative(:,:,:,:,:,:)
6689  real, allocatable:: answer_max(:,:,:,:,:,:)
6690  real, allocatable:: answer_min(:,:,:,:,:,:)
6691 
6692  continue
6693  err_flag = .false.
6694 
6695  if ( significant_digits < 1 ) then
6696  write(*,*) ' *** Error [AssertEQ] *** '
6697  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6698  call abortprogram('')
6699  end if
6700 
6701  answer_shape = shape(answer)
6702  check_shape = shape(check)
6703 
6704  consist_shape = answer_shape == check_shape
6705 
6706  if (.not. all(consist_shape)) then
6707  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6708  write(*,*) ''
6709  write(*,*) ' shape of check is (', check_shape, ')'
6710  write(*,*) ' is INCORRECT'
6711  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6712 
6713  call abortprogram('')
6714  end if
6715 
6716 
6717  allocate( mask_array( &
6718  & answer_shape(1), &
6719 
6720  & answer_shape(2), &
6721 
6722  & answer_shape(3), &
6723 
6724  & answer_shape(4), &
6725 
6726  & answer_shape(5), &
6727 
6728  & answer_shape(6) ) &
6729  & )
6730 
6731  allocate( judge( &
6732  & answer_shape(1), &
6733 
6734  & answer_shape(2), &
6735 
6736  & answer_shape(3), &
6737 
6738  & answer_shape(4), &
6739 
6740  & answer_shape(5), &
6741 
6742  & answer_shape(6) ) &
6743  & )
6744 
6745  allocate( judge_rev( &
6746  & answer_shape(1), &
6747 
6748  & answer_shape(2), &
6749 
6750  & answer_shape(3), &
6751 
6752  & answer_shape(4), &
6753 
6754  & answer_shape(5), &
6755 
6756  & answer_shape(6) ) &
6757  & )
6758 
6759  allocate( answer_negative( &
6760  & answer_shape(1), &
6761 
6762  & answer_shape(2), &
6763 
6764  & answer_shape(3), &
6765 
6766  & answer_shape(4), &
6767 
6768  & answer_shape(5), &
6769 
6770  & answer_shape(6) ) &
6771  & )
6772 
6773  allocate( check_negative( &
6774  & answer_shape(1), &
6775 
6776  & answer_shape(2), &
6777 
6778  & answer_shape(3), &
6779 
6780  & answer_shape(4), &
6781 
6782  & answer_shape(5), &
6783 
6784  & answer_shape(6) ) &
6785  & )
6786 
6787  allocate( both_negative( &
6788  & answer_shape(1), &
6789 
6790  & answer_shape(2), &
6791 
6792  & answer_shape(3), &
6793 
6794  & answer_shape(4), &
6795 
6796  & answer_shape(5), &
6797 
6798  & answer_shape(6) ) &
6799  & )
6800 
6801  allocate( answer_max( &
6802  & answer_shape(1), &
6803 
6804  & answer_shape(2), &
6805 
6806  & answer_shape(3), &
6807 
6808  & answer_shape(4), &
6809 
6810  & answer_shape(5), &
6811 
6812  & answer_shape(6) ) &
6813  & )
6814 
6815  allocate( answer_min( &
6816  & answer_shape(1), &
6817 
6818  & answer_shape(2), &
6819 
6820  & answer_shape(3), &
6821 
6822  & answer_shape(4), &
6823 
6824  & answer_shape(5), &
6825 
6826  & answer_shape(6) ) &
6827  & )
6828 
6829  answer_negative = answer < 0.0
6830  check_negative = check < 0.0
6831  both_negative = answer_negative .and. check_negative
6832 
6833  where (both_negative)
6834  answer_max = &
6835  & answer &
6836  & * ( 1.0 &
6837  & - 0.1 ** significant_digits ) &
6838  & + 0.1 ** (- ignore_digits)
6839 
6840  answer_min = &
6841  & answer &
6842  & * ( 1.0 &
6843  & + 0.1 ** significant_digits ) &
6844  & - 0.1 ** (- ignore_digits)
6845  elsewhere
6846  answer_max = &
6847  & answer &
6848  & * ( 1.0 &
6849  & + 0.1 ** significant_digits ) &
6850  & + 0.1 ** (- ignore_digits)
6851 
6852  answer_min = &
6853  & answer &
6854  & * ( 1.0 &
6855  & - 0.1 ** significant_digits ) &
6856  & - 0.1 ** (- ignore_digits)
6857  end where
6858 
6859  judge = answer_max > check .and. check > answer_min
6860  judge_rev = .not. judge
6861  err_flag = any(judge_rev)
6862  mask_array = 1
6863  pos = maxloc(mask_array, judge_rev)
6864 
6865  if (err_flag) then
6866 
6867  wrong = check( &
6868  & pos(1), &
6869 
6870  & pos(2), &
6871 
6872  & pos(3), &
6873 
6874  & pos(4), &
6875 
6876  & pos(5), &
6877 
6878  & pos(6) )
6879 
6880  right_max = answer_max( &
6881  & pos(1), &
6882 
6883  & pos(2), &
6884 
6885  & pos(3), &
6886 
6887  & pos(4), &
6888 
6889  & pos(5), &
6890 
6891  & pos(6) )
6892 
6893  right_min = answer_min( &
6894  & pos(1), &
6895 
6896  & pos(2), &
6897 
6898  & pos(3), &
6899 
6900  & pos(4), &
6901 
6902  & pos(5), &
6903 
6904  & pos(6) )
6905 
6906  if ( right_max < right_min ) then
6907  right_tmp = right_max
6908  right_max = right_min
6909  right_min = right_tmp
6910  end if
6911 
6912  write(unit=pos_array(1), fmt="(i20)") pos(1)
6913 
6914  write(unit=pos_array(2), fmt="(i20)") pos(2)
6915 
6916  write(unit=pos_array(3), fmt="(i20)") pos(3)
6917 
6918  write(unit=pos_array(4), fmt="(i20)") pos(4)
6919 
6920  write(unit=pos_array(5), fmt="(i20)") pos(5)
6921 
6922  write(unit=pos_array(6), fmt="(i20)") pos(6)
6923 
6924 
6925  pos_str = '(' // &
6926  & trim(adjustl(pos_array(1))) // ',' // &
6927 
6928  & trim(adjustl(pos_array(2))) // ',' // &
6929 
6930  & trim(adjustl(pos_array(3))) // ',' // &
6931 
6932  & trim(adjustl(pos_array(4))) // ',' // &
6933 
6934  & trim(adjustl(pos_array(5))) // ',' // &
6935 
6936  & trim(adjustl(pos_array(6))) // ')'
6937 
6938  end if
6939  deallocate(mask_array, judge, judge_rev)
6940  deallocate(answer_negative, check_negative, both_negative)
6941  deallocate(answer_max, answer_min)
6942 
6943 
6944 
6945  if (err_flag) then
6946  pos_str_space = ''
6947  pos_str_len = len_trim(pos_str)
6948 
6949  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6950  write(*,*) ''
6951  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6952  write(*,*) ' is NOT EQUAL to'
6953  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6954  & // ' ', right_min, ' < '
6955  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6956 
6957  call abortprogram('')
6958  else
6959  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6960  end if
6961 
6962 
6963  end subroutine dctestassertequalreal6digits
6964 
6965 
6966  subroutine dctestassertequalreal7digits( &
6967  & message, answer, check, significant_digits, ignore_digits )
6968  use sysdep, only: abortprogram
6969  use dc_types, only: string, token
6970  implicit none
6971  character(*), intent(in):: message
6972  real, intent(in):: answer(:,:,:,:,:,:,:)
6973  real, intent(in):: check(:,:,:,:,:,:,:)
6974  integer, intent(in):: significant_digits
6975  integer, intent(in):: ignore_digits
6976  logical:: err_flag
6977  character(STRING):: pos_str
6978  real:: wrong, right_max, right_min
6979  character(STRING):: pos_str_space
6980  integer:: pos_str_len
6981  real:: right_tmp
6982 
6983  integer:: answer_shape(7), check_shape(7), pos(7)
6984  logical:: consist_shape(7)
6985  character(TOKEN):: pos_array(7)
6986  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
6987  logical, allocatable:: judge(:,:,:,:,:,:,:)
6988  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
6989  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
6990  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
6991  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
6992  real, allocatable:: answer_max(:,:,:,:,:,:,:)
6993  real, allocatable:: answer_min(:,:,:,:,:,:,:)
6994 
6995  continue
6996  err_flag = .false.
6997 
6998  if ( significant_digits < 1 ) then
6999  write(*,*) ' *** Error [AssertEQ] *** '
7000  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7001  call abortprogram('')
7002  end if
7003 
7004  answer_shape = shape(answer)
7005  check_shape = shape(check)
7006 
7007  consist_shape = answer_shape == check_shape
7008 
7009  if (.not. all(consist_shape)) then
7010  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7011  write(*,*) ''
7012  write(*,*) ' shape of check is (', check_shape, ')'
7013  write(*,*) ' is INCORRECT'
7014  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7015 
7016  call abortprogram('')
7017  end if
7018 
7019 
7020  allocate( mask_array( &
7021  & answer_shape(1), &
7022 
7023  & answer_shape(2), &
7024 
7025  & answer_shape(3), &
7026 
7027  & answer_shape(4), &
7028 
7029  & answer_shape(5), &
7030 
7031  & answer_shape(6), &
7032 
7033  & answer_shape(7) ) &
7034  & )
7035 
7036  allocate( judge( &
7037  & answer_shape(1), &
7038 
7039  & answer_shape(2), &
7040 
7041  & answer_shape(3), &
7042 
7043  & answer_shape(4), &
7044 
7045  & answer_shape(5), &
7046 
7047  & answer_shape(6), &
7048 
7049  & answer_shape(7) ) &
7050  & )
7051 
7052  allocate( judge_rev( &
7053  & answer_shape(1), &
7054 
7055  & answer_shape(2), &
7056 
7057  & answer_shape(3), &
7058 
7059  & answer_shape(4), &
7060 
7061  & answer_shape(5), &
7062 
7063  & answer_shape(6), &
7064 
7065  & answer_shape(7) ) &
7066  & )
7067 
7068  allocate( answer_negative( &
7069  & answer_shape(1), &
7070 
7071  & answer_shape(2), &
7072 
7073  & answer_shape(3), &
7074 
7075  & answer_shape(4), &
7076 
7077  & answer_shape(5), &
7078 
7079  & answer_shape(6), &
7080 
7081  & answer_shape(7) ) &
7082  & )
7083 
7084  allocate( check_negative( &
7085  & answer_shape(1), &
7086 
7087  & answer_shape(2), &
7088 
7089  & answer_shape(3), &
7090 
7091  & answer_shape(4), &
7092 
7093  & answer_shape(5), &
7094 
7095  & answer_shape(6), &
7096 
7097  & answer_shape(7) ) &
7098  & )
7099 
7100  allocate( both_negative( &
7101  & answer_shape(1), &
7102 
7103  & answer_shape(2), &
7104 
7105  & answer_shape(3), &
7106 
7107  & answer_shape(4), &
7108 
7109  & answer_shape(5), &
7110 
7111  & answer_shape(6), &
7112 
7113  & answer_shape(7) ) &
7114  & )
7115 
7116  allocate( answer_max( &
7117  & answer_shape(1), &
7118 
7119  & answer_shape(2), &
7120 
7121  & answer_shape(3), &
7122 
7123  & answer_shape(4), &
7124 
7125  & answer_shape(5), &
7126 
7127  & answer_shape(6), &
7128 
7129  & answer_shape(7) ) &
7130  & )
7131 
7132  allocate( answer_min( &
7133  & answer_shape(1), &
7134 
7135  & answer_shape(2), &
7136 
7137  & answer_shape(3), &
7138 
7139  & answer_shape(4), &
7140 
7141  & answer_shape(5), &
7142 
7143  & answer_shape(6), &
7144 
7145  & answer_shape(7) ) &
7146  & )
7147 
7148  answer_negative = answer < 0.0
7149  check_negative = check < 0.0
7150  both_negative = answer_negative .and. check_negative
7151 
7152  where (both_negative)
7153  answer_max = &
7154  & answer &
7155  & * ( 1.0 &
7156  & - 0.1 ** significant_digits ) &
7157  & + 0.1 ** (- ignore_digits)
7158 
7159  answer_min = &
7160  & answer &
7161  & * ( 1.0 &
7162  & + 0.1 ** significant_digits ) &
7163  & - 0.1 ** (- ignore_digits)
7164  elsewhere
7165  answer_max = &
7166  & answer &
7167  & * ( 1.0 &
7168  & + 0.1 ** significant_digits ) &
7169  & + 0.1 ** (- ignore_digits)
7170 
7171  answer_min = &
7172  & answer &
7173  & * ( 1.0 &
7174  & - 0.1 ** significant_digits ) &
7175  & - 0.1 ** (- ignore_digits)
7176  end where
7177 
7178  judge = answer_max > check .and. check > answer_min
7179  judge_rev = .not. judge
7180  err_flag = any(judge_rev)
7181  mask_array = 1
7182  pos = maxloc(mask_array, judge_rev)
7183 
7184  if (err_flag) then
7185 
7186  wrong = check( &
7187  & pos(1), &
7188 
7189  & pos(2), &
7190 
7191  & pos(3), &
7192 
7193  & pos(4), &
7194 
7195  & pos(5), &
7196 
7197  & pos(6), &
7198 
7199  & pos(7) )
7200 
7201  right_max = answer_max( &
7202  & pos(1), &
7203 
7204  & pos(2), &
7205 
7206  & pos(3), &
7207 
7208  & pos(4), &
7209 
7210  & pos(5), &
7211 
7212  & pos(6), &
7213 
7214  & pos(7) )
7215 
7216  right_min = answer_min( &
7217  & pos(1), &
7218 
7219  & pos(2), &
7220 
7221  & pos(3), &
7222 
7223  & pos(4), &
7224 
7225  & pos(5), &
7226 
7227  & pos(6), &
7228 
7229  & pos(7) )
7230 
7231  if ( right_max < right_min ) then
7232  right_tmp = right_max
7233  right_max = right_min
7234  right_min = right_tmp
7235  end if
7236 
7237  write(unit=pos_array(1), fmt="(i20)") pos(1)
7238 
7239  write(unit=pos_array(2), fmt="(i20)") pos(2)
7240 
7241  write(unit=pos_array(3), fmt="(i20)") pos(3)
7242 
7243  write(unit=pos_array(4), fmt="(i20)") pos(4)
7244 
7245  write(unit=pos_array(5), fmt="(i20)") pos(5)
7246 
7247  write(unit=pos_array(6), fmt="(i20)") pos(6)
7248 
7249  write(unit=pos_array(7), fmt="(i20)") pos(7)
7250 
7251 
7252  pos_str = '(' // &
7253  & trim(adjustl(pos_array(1))) // ',' // &
7254 
7255  & trim(adjustl(pos_array(2))) // ',' // &
7256 
7257  & trim(adjustl(pos_array(3))) // ',' // &
7258 
7259  & trim(adjustl(pos_array(4))) // ',' // &
7260 
7261  & trim(adjustl(pos_array(5))) // ',' // &
7262 
7263  & trim(adjustl(pos_array(6))) // ',' // &
7264 
7265  & trim(adjustl(pos_array(7))) // ')'
7266 
7267  end if
7268  deallocate(mask_array, judge, judge_rev)
7269  deallocate(answer_negative, check_negative, both_negative)
7270  deallocate(answer_max, answer_min)
7271 
7272 
7273 
7274  if (err_flag) then
7275  pos_str_space = ''
7276  pos_str_len = len_trim(pos_str)
7277 
7278  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7279  write(*,*) ''
7280  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7281  write(*,*) ' is NOT EQUAL to'
7282  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7283  & // ' ', right_min, ' < '
7284  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7285 
7286  call abortprogram('')
7287  else
7288  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7289  end if
7290 
7291 
7292  end subroutine dctestassertequalreal7digits
7293 
7294 
7295  subroutine dctestassertequaldouble0digits( &
7296  & message, answer, check, significant_digits, ignore_digits )
7297  use sysdep, only: abortprogram
7298  use dc_types, only: string, token
7299  implicit none
7300  character(*), intent(in):: message
7301  real(DP), intent(in):: answer
7302  real(DP), intent(in):: check
7303  integer, intent(in):: significant_digits
7304  integer, intent(in):: ignore_digits
7305  logical:: err_flag
7306  character(STRING):: pos_str
7307  real(DP):: wrong, right_max, right_min
7308  character(STRING):: pos_str_space
7309  integer:: pos_str_len
7310  real(DP):: right_tmp
7311 
7312  real(DP):: answer_max
7313  real(DP):: answer_min
7314 
7315  continue
7316  err_flag = .false.
7317 
7318  if ( significant_digits < 1 ) then
7319  write(*,*) ' *** Error [AssertEQ] *** '
7320  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7321  call abortprogram('')
7322  end if
7323 
7324  if ( answer < 0.0_dp .and. check < 0.0_dp ) then
7325  answer_max = &
7326  & answer &
7327  & * ( 1.0_dp &
7328  & - 0.1_dp ** significant_digits ) &
7329  & + 0.1_dp ** (- ignore_digits)
7330 
7331  answer_min = &
7332  & answer &
7333  & * ( 1.0_dp &
7334  & + 0.1_dp ** significant_digits ) &
7335  & - 0.1_dp ** (- ignore_digits)
7336  else
7337 
7338  answer_max = &
7339  & answer &
7340  & * ( 1.0_dp &
7341  & + 0.1_dp ** significant_digits ) &
7342  & + 0.1_dp ** (- ignore_digits)
7343 
7344  answer_min = &
7345  & answer &
7346  & * ( 1.0_dp &
7347  & - 0.1_dp ** significant_digits ) &
7348  & - 0.1_dp ** (- ignore_digits)
7349  end if
7350 
7351  wrong = check
7352  right_max = answer_max
7353  right_min = answer_min
7354  if ( right_max < right_min ) then
7355  right_tmp = right_max
7356  right_max = right_min
7357  right_min = right_tmp
7358  end if
7359 
7360  err_flag = .not. (answer_max > check .and. check > answer_min)
7361 
7362  pos_str = ''
7363 
7364 
7365 
7366  if (err_flag) then
7367  pos_str_space = ''
7368  pos_str_len = len_trim(pos_str)
7369 
7370  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7371  write(*,*) ''
7372  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7373  write(*,*) ' is NOT EQUAL to'
7374  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7375  & // ' ', right_min, ' < '
7376  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7377 
7378  call abortprogram('')
7379  else
7380  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7381  end if
7382 
7383 
7384  end subroutine dctestassertequaldouble0digits
7385 
7386 
7387  subroutine dctestassertequaldouble1digits( &
7388  & message, answer, check, significant_digits, ignore_digits )
7389  use sysdep, only: abortprogram
7390  use dc_types, only: string, token
7391  implicit none
7392  character(*), intent(in):: message
7393  real(DP), intent(in):: answer(:)
7394  real(DP), intent(in):: check(:)
7395  integer, intent(in):: significant_digits
7396  integer, intent(in):: ignore_digits
7397  logical:: err_flag
7398  character(STRING):: pos_str
7399  real(DP):: wrong, right_max, right_min
7400  character(STRING):: pos_str_space
7401  integer:: pos_str_len
7402  real(DP):: right_tmp
7403 
7404  integer:: answer_shape(1), check_shape(1), pos(1)
7405  logical:: consist_shape(1)
7406  character(TOKEN):: pos_array(1)
7407  integer, allocatable:: mask_array(:)
7408  logical, allocatable:: judge(:)
7409  logical, allocatable:: judge_rev(:)
7410  logical, allocatable:: answer_negative(:)
7411  logical, allocatable:: check_negative(:)
7412  logical, allocatable:: both_negative(:)
7413  real(DP), allocatable:: answer_max(:)
7414  real(DP), allocatable:: answer_min(:)
7415 
7416  continue
7417  err_flag = .false.
7418 
7419  if ( significant_digits < 1 ) then
7420  write(*,*) ' *** Error [AssertEQ] *** '
7421  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7422  call abortprogram('')
7423  end if
7424 
7425  answer_shape = shape(answer)
7426  check_shape = shape(check)
7427 
7428  consist_shape = answer_shape == check_shape
7429 
7430  if (.not. all(consist_shape)) then
7431  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7432  write(*,*) ''
7433  write(*,*) ' shape of check is (', check_shape, ')'
7434  write(*,*) ' is INCORRECT'
7435  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7436 
7437  call abortprogram('')
7438  end if
7439 
7440 
7441  allocate( mask_array( &
7442 
7443  & answer_shape(1) ) &
7444  & )
7445 
7446  allocate( judge( &
7447 
7448  & answer_shape(1) ) &
7449  & )
7450 
7451  allocate( judge_rev( &
7452 
7453  & answer_shape(1) ) &
7454  & )
7455 
7456  allocate( answer_negative( &
7457 
7458  & answer_shape(1) ) &
7459  & )
7460 
7461  allocate( check_negative( &
7462 
7463  & answer_shape(1) ) &
7464  & )
7465 
7466  allocate( both_negative( &
7467 
7468  & answer_shape(1) ) &
7469  & )
7470 
7471  allocate( answer_max( &
7472 
7473  & answer_shape(1) ) &
7474  & )
7475 
7476  allocate( answer_min( &
7477 
7478  & answer_shape(1) ) &
7479  & )
7480 
7481  answer_negative = answer < 0.0_dp
7482  check_negative = check < 0.0_dp
7483  both_negative = answer_negative .and. check_negative
7484 
7485  where (both_negative)
7486  answer_max = &
7487  & answer &
7488  & * ( 1.0_dp &
7489  & - 0.1_dp ** significant_digits ) &
7490  & + 0.1_dp ** (- ignore_digits)
7491 
7492  answer_min = &
7493  & answer &
7494  & * ( 1.0_dp &
7495  & + 0.1_dp ** significant_digits ) &
7496  & - 0.1_dp ** (- ignore_digits)
7497  elsewhere
7498  answer_max = &
7499  & answer &
7500  & * ( 1.0_dp &
7501  & + 0.1_dp ** significant_digits ) &
7502  & + 0.1_dp ** (- ignore_digits)
7503 
7504  answer_min = &
7505  & answer &
7506  & * ( 1.0_dp &
7507  & - 0.1_dp ** significant_digits ) &
7508  & - 0.1_dp ** (- ignore_digits)
7509  end where
7510 
7511  judge = answer_max > check .and. check > answer_min
7512  judge_rev = .not. judge
7513  err_flag = any(judge_rev)
7514  mask_array = 1
7515  pos = maxloc(mask_array, judge_rev)
7516 
7517  if (err_flag) then
7518 
7519  wrong = check( &
7520 
7521  & pos(1) )
7522 
7523  right_max = answer_max( &
7524 
7525  & pos(1) )
7526 
7527  right_min = answer_min( &
7528 
7529  & pos(1) )
7530 
7531  if ( right_max < right_min ) then
7532  right_tmp = right_max
7533  right_max = right_min
7534  right_min = right_tmp
7535  end if
7536 
7537  write(unit=pos_array(1), fmt="(i20)") pos(1)
7538 
7539 
7540  pos_str = '(' // &
7541 
7542  & trim(adjustl(pos_array(1))) // ')'
7543 
7544  end if
7545  deallocate(mask_array, judge, judge_rev)
7546  deallocate(answer_negative, check_negative, both_negative)
7547  deallocate(answer_max, answer_min)
7548 
7549 
7550 
7551  if (err_flag) then
7552  pos_str_space = ''
7553  pos_str_len = len_trim(pos_str)
7554 
7555  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7556  write(*,*) ''
7557  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7558  write(*,*) ' is NOT EQUAL to'
7559  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7560  & // ' ', right_min, ' < '
7561  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7562 
7563  call abortprogram('')
7564  else
7565  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7566  end if
7567 
7568 
7569  end subroutine dctestassertequaldouble1digits
7570 
7571 
7572  subroutine dctestassertequaldouble2digits( &
7573  & message, answer, check, significant_digits, ignore_digits )
7574  use sysdep, only: abortprogram
7575  use dc_types, only: string, token
7576  implicit none
7577  character(*), intent(in):: message
7578  real(DP), intent(in):: answer(:,:)
7579  real(DP), intent(in):: check(:,:)
7580  integer, intent(in):: significant_digits
7581  integer, intent(in):: ignore_digits
7582  logical:: err_flag
7583  character(STRING):: pos_str
7584  real(DP):: wrong, right_max, right_min
7585  character(STRING):: pos_str_space
7586  integer:: pos_str_len
7587  real(DP):: right_tmp
7588 
7589  integer:: answer_shape(2), check_shape(2), pos(2)
7590  logical:: consist_shape(2)
7591  character(TOKEN):: pos_array(2)
7592  integer, allocatable:: mask_array(:,:)
7593  logical, allocatable:: judge(:,:)
7594  logical, allocatable:: judge_rev(:,:)
7595  logical, allocatable:: answer_negative(:,:)
7596  logical, allocatable:: check_negative(:,:)
7597  logical, allocatable:: both_negative(:,:)
7598  real(DP), allocatable:: answer_max(:,:)
7599  real(DP), allocatable:: answer_min(:,:)
7600 
7601  continue
7602  err_flag = .false.
7603 
7604  if ( significant_digits < 1 ) then
7605  write(*,*) ' *** Error [AssertEQ] *** '
7606  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7607  call abortprogram('')
7608  end if
7609 
7610  answer_shape = shape(answer)
7611  check_shape = shape(check)
7612 
7613  consist_shape = answer_shape == check_shape
7614 
7615  if (.not. all(consist_shape)) then
7616  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7617  write(*,*) ''
7618  write(*,*) ' shape of check is (', check_shape, ')'
7619  write(*,*) ' is INCORRECT'
7620  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7621 
7622  call abortprogram('')
7623  end if
7624 
7625 
7626  allocate( mask_array( &
7627  & answer_shape(1), &
7628 
7629  & answer_shape(2) ) &
7630  & )
7631 
7632  allocate( judge( &
7633  & answer_shape(1), &
7634 
7635  & answer_shape(2) ) &
7636  & )
7637 
7638  allocate( judge_rev( &
7639  & answer_shape(1), &
7640 
7641  & answer_shape(2) ) &
7642  & )
7643 
7644  allocate( answer_negative( &
7645  & answer_shape(1), &
7646 
7647  & answer_shape(2) ) &
7648  & )
7649 
7650  allocate( check_negative( &
7651  & answer_shape(1), &
7652 
7653  & answer_shape(2) ) &
7654  & )
7655 
7656  allocate( both_negative( &
7657  & answer_shape(1), &
7658 
7659  & answer_shape(2) ) &
7660  & )
7661 
7662  allocate( answer_max( &
7663  & answer_shape(1), &
7664 
7665  & answer_shape(2) ) &
7666  & )
7667 
7668  allocate( answer_min( &
7669  & answer_shape(1), &
7670 
7671  & answer_shape(2) ) &
7672  & )
7673 
7674  answer_negative = answer < 0.0_dp
7675  check_negative = check < 0.0_dp
7676  both_negative = answer_negative .and. check_negative
7677 
7678  where (both_negative)
7679  answer_max = &
7680  & answer &
7681  & * ( 1.0_dp &
7682  & - 0.1_dp ** significant_digits ) &
7683  & + 0.1_dp ** (- ignore_digits)
7684 
7685  answer_min = &
7686  & answer &
7687  & * ( 1.0_dp &
7688  & + 0.1_dp ** significant_digits ) &
7689  & - 0.1_dp ** (- ignore_digits)
7690  elsewhere
7691  answer_max = &
7692  & answer &
7693  & * ( 1.0_dp &
7694  & + 0.1_dp ** significant_digits ) &
7695  & + 0.1_dp ** (- ignore_digits)
7696 
7697  answer_min = &
7698  & answer &
7699  & * ( 1.0_dp &
7700  & - 0.1_dp ** significant_digits ) &
7701  & - 0.1_dp ** (- ignore_digits)
7702  end where
7703 
7704  judge = answer_max > check .and. check > answer_min
7705  judge_rev = .not. judge
7706  err_flag = any(judge_rev)
7707  mask_array = 1
7708  pos = maxloc(mask_array, judge_rev)
7709 
7710  if (err_flag) then
7711 
7712  wrong = check( &
7713  & pos(1), &
7714 
7715  & pos(2) )
7716 
7717  right_max = answer_max( &
7718  & pos(1), &
7719 
7720  & pos(2) )
7721 
7722  right_min = answer_min( &
7723  & pos(1), &
7724 
7725  & pos(2) )
7726 
7727  if ( right_max < right_min ) then
7728  right_tmp = right_max
7729  right_max = right_min
7730  right_min = right_tmp
7731  end if
7732 
7733  write(unit=pos_array(1), fmt="(i20)") pos(1)
7734 
7735  write(unit=pos_array(2), fmt="(i20)") pos(2)
7736 
7737 
7738  pos_str = '(' // &
7739  & trim(adjustl(pos_array(1))) // ',' // &
7740 
7741  & trim(adjustl(pos_array(2))) // ')'
7742 
7743  end if
7744  deallocate(mask_array, judge, judge_rev)
7745  deallocate(answer_negative, check_negative, both_negative)
7746  deallocate(answer_max, answer_min)
7747 
7748 
7749 
7750  if (err_flag) then
7751  pos_str_space = ''
7752  pos_str_len = len_trim(pos_str)
7753 
7754  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7755  write(*,*) ''
7756  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7757  write(*,*) ' is NOT EQUAL to'
7758  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7759  & // ' ', right_min, ' < '
7760  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7761 
7762  call abortprogram('')
7763  else
7764  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7765  end if
7766 
7767 
7768  end subroutine dctestassertequaldouble2digits
7769 
7770 
7771  subroutine dctestassertequaldouble3digits( &
7772  & message, answer, check, significant_digits, ignore_digits )
7773  use sysdep, only: abortprogram
7774  use dc_types, only: string, token
7775  implicit none
7776  character(*), intent(in):: message
7777  real(DP), intent(in):: answer(:,:,:)
7778  real(DP), intent(in):: check(:,:,:)
7779  integer, intent(in):: significant_digits
7780  integer, intent(in):: ignore_digits
7781  logical:: err_flag
7782  character(STRING):: pos_str
7783  real(DP):: wrong, right_max, right_min
7784  character(STRING):: pos_str_space
7785  integer:: pos_str_len
7786  real(DP):: right_tmp
7787 
7788  integer:: answer_shape(3), check_shape(3), pos(3)
7789  logical:: consist_shape(3)
7790  character(TOKEN):: pos_array(3)
7791  integer, allocatable:: mask_array(:,:,:)
7792  logical, allocatable:: judge(:,:,:)
7793  logical, allocatable:: judge_rev(:,:,:)
7794  logical, allocatable:: answer_negative(:,:,:)
7795  logical, allocatable:: check_negative(:,:,:)
7796  logical, allocatable:: both_negative(:,:,:)
7797  real(DP), allocatable:: answer_max(:,:,:)
7798  real(DP), allocatable:: answer_min(:,:,:)
7799 
7800  continue
7801  err_flag = .false.
7802 
7803  if ( significant_digits < 1 ) then
7804  write(*,*) ' *** Error [AssertEQ] *** '
7805  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7806  call abortprogram('')
7807  end if
7808 
7809  answer_shape = shape(answer)
7810  check_shape = shape(check)
7811 
7812  consist_shape = answer_shape == check_shape
7813 
7814  if (.not. all(consist_shape)) then
7815  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7816  write(*,*) ''
7817  write(*,*) ' shape of check is (', check_shape, ')'
7818  write(*,*) ' is INCORRECT'
7819  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7820 
7821  call abortprogram('')
7822  end if
7823 
7824 
7825  allocate( mask_array( &
7826  & answer_shape(1), &
7827 
7828  & answer_shape(2), &
7829 
7830  & answer_shape(3) ) &
7831  & )
7832 
7833  allocate( judge( &
7834  & answer_shape(1), &
7835 
7836  & answer_shape(2), &
7837 
7838  & answer_shape(3) ) &
7839  & )
7840 
7841  allocate( judge_rev( &
7842  & answer_shape(1), &
7843 
7844  & answer_shape(2), &
7845 
7846  & answer_shape(3) ) &
7847  & )
7848 
7849  allocate( answer_negative( &
7850  & answer_shape(1), &
7851 
7852  & answer_shape(2), &
7853 
7854  & answer_shape(3) ) &
7855  & )
7856 
7857  allocate( check_negative( &
7858  & answer_shape(1), &
7859 
7860  & answer_shape(2), &
7861 
7862  & answer_shape(3) ) &
7863  & )
7864 
7865  allocate( both_negative( &
7866  & answer_shape(1), &
7867 
7868  & answer_shape(2), &
7869 
7870  & answer_shape(3) ) &
7871  & )
7872 
7873  allocate( answer_max( &
7874  & answer_shape(1), &
7875 
7876  & answer_shape(2), &
7877 
7878  & answer_shape(3) ) &
7879  & )
7880 
7881  allocate( answer_min( &
7882  & answer_shape(1), &
7883 
7884  & answer_shape(2), &
7885 
7886  & answer_shape(3) ) &
7887  & )
7888 
7889  answer_negative = answer < 0.0_dp
7890  check_negative = check < 0.0_dp
7891  both_negative = answer_negative .and. check_negative
7892 
7893  where (both_negative)
7894  answer_max = &
7895  & answer &
7896  & * ( 1.0_dp &
7897  & - 0.1_dp ** significant_digits ) &
7898  & + 0.1_dp ** (- ignore_digits)
7899 
7900  answer_min = &
7901  & answer &
7902  & * ( 1.0_dp &
7903  & + 0.1_dp ** significant_digits ) &
7904  & - 0.1_dp ** (- ignore_digits)
7905  elsewhere
7906  answer_max = &
7907  & answer &
7908  & * ( 1.0_dp &
7909  & + 0.1_dp ** significant_digits ) &
7910  & + 0.1_dp ** (- ignore_digits)
7911 
7912  answer_min = &
7913  & answer &
7914  & * ( 1.0_dp &
7915  & - 0.1_dp ** significant_digits ) &
7916  & - 0.1_dp ** (- ignore_digits)
7917  end where
7918 
7919  judge = answer_max > check .and. check > answer_min
7920  judge_rev = .not. judge
7921  err_flag = any(judge_rev)
7922  mask_array = 1
7923  pos = maxloc(mask_array, judge_rev)
7924 
7925  if (err_flag) then
7926 
7927  wrong = check( &
7928  & pos(1), &
7929 
7930  & pos(2), &
7931 
7932  & pos(3) )
7933 
7934  right_max = answer_max( &
7935  & pos(1), &
7936 
7937  & pos(2), &
7938 
7939  & pos(3) )
7940 
7941  right_min = answer_min( &
7942  & pos(1), &
7943 
7944  & pos(2), &
7945 
7946  & pos(3) )
7947 
7948  if ( right_max < right_min ) then
7949  right_tmp = right_max
7950  right_max = right_min
7951  right_min = right_tmp
7952  end if
7953 
7954  write(unit=pos_array(1), fmt="(i20)") pos(1)
7955 
7956  write(unit=pos_array(2), fmt="(i20)") pos(2)
7957 
7958  write(unit=pos_array(3), fmt="(i20)") pos(3)
7959 
7960 
7961  pos_str = '(' // &
7962  & trim(adjustl(pos_array(1))) // ',' // &
7963 
7964  & trim(adjustl(pos_array(2))) // ',' // &
7965 
7966  & trim(adjustl(pos_array(3))) // ')'
7967 
7968  end if
7969  deallocate(mask_array, judge, judge_rev)
7970  deallocate(answer_negative, check_negative, both_negative)
7971  deallocate(answer_max, answer_min)
7972 
7973 
7974 
7975  if (err_flag) then
7976  pos_str_space = ''
7977  pos_str_len = len_trim(pos_str)
7978 
7979  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7980  write(*,*) ''
7981  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7982  write(*,*) ' is NOT EQUAL to'
7983  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7984  & // ' ', right_min, ' < '
7985  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7986 
7987  call abortprogram('')
7988  else
7989  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7990  end if
7991 
7992 
7993  end subroutine dctestassertequaldouble3digits
7994 
7995 
7996  subroutine dctestassertequaldouble4digits( &
7997  & message, answer, check, significant_digits, ignore_digits )
7998  use sysdep, only: abortprogram
7999  use dc_types, only: string, token
8000  implicit none
8001  character(*), intent(in):: message
8002  real(DP), intent(in):: answer(:,:,:,:)
8003  real(DP), intent(in):: check(:,:,:,:)
8004  integer, intent(in):: significant_digits
8005  integer, intent(in):: ignore_digits
8006  logical:: err_flag
8007  character(STRING):: pos_str
8008  real(DP):: wrong, right_max, right_min
8009  character(STRING):: pos_str_space
8010  integer:: pos_str_len
8011  real(DP):: right_tmp
8012 
8013  integer:: answer_shape(4), check_shape(4), pos(4)
8014  logical:: consist_shape(4)
8015  character(TOKEN):: pos_array(4)
8016  integer, allocatable:: mask_array(:,:,:,:)
8017  logical, allocatable:: judge(:,:,:,:)
8018  logical, allocatable:: judge_rev(:,:,:,:)
8019  logical, allocatable:: answer_negative(:,:,:,:)
8020  logical, allocatable:: check_negative(:,:,:,:)
8021  logical, allocatable:: both_negative(:,:,:,:)
8022  real(DP), allocatable:: answer_max(:,:,:,:)
8023  real(DP), allocatable:: answer_min(:,:,:,:)
8024 
8025  continue
8026  err_flag = .false.
8027 
8028  if ( significant_digits < 1 ) then
8029  write(*,*) ' *** Error [AssertEQ] *** '
8030  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8031  call abortprogram('')
8032  end if
8033 
8034  answer_shape = shape(answer)
8035  check_shape = shape(check)
8036 
8037  consist_shape = answer_shape == check_shape
8038 
8039  if (.not. all(consist_shape)) then
8040  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8041  write(*,*) ''
8042  write(*,*) ' shape of check is (', check_shape, ')'
8043  write(*,*) ' is INCORRECT'
8044  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8045 
8046  call abortprogram('')
8047  end if
8048 
8049 
8050  allocate( mask_array( &
8051  & answer_shape(1), &
8052 
8053  & answer_shape(2), &
8054 
8055  & answer_shape(3), &
8056 
8057  & answer_shape(4) ) &
8058  & )
8059 
8060  allocate( judge( &
8061  & answer_shape(1), &
8062 
8063  & answer_shape(2), &
8064 
8065  & answer_shape(3), &
8066 
8067  & answer_shape(4) ) &
8068  & )
8069 
8070  allocate( judge_rev( &
8071  & answer_shape(1), &
8072 
8073  & answer_shape(2), &
8074 
8075  & answer_shape(3), &
8076 
8077  & answer_shape(4) ) &
8078  & )
8079 
8080  allocate( answer_negative( &
8081  & answer_shape(1), &
8082 
8083  & answer_shape(2), &
8084 
8085  & answer_shape(3), &
8086 
8087  & answer_shape(4) ) &
8088  & )
8089 
8090  allocate( check_negative( &
8091  & answer_shape(1), &
8092 
8093  & answer_shape(2), &
8094 
8095  & answer_shape(3), &
8096 
8097  & answer_shape(4) ) &
8098  & )
8099 
8100  allocate( both_negative( &
8101  & answer_shape(1), &
8102 
8103  & answer_shape(2), &
8104 
8105  & answer_shape(3), &
8106 
8107  & answer_shape(4) ) &
8108  & )
8109 
8110  allocate( answer_max( &
8111  & answer_shape(1), &
8112 
8113  & answer_shape(2), &
8114 
8115  & answer_shape(3), &
8116 
8117  & answer_shape(4) ) &
8118  & )
8119 
8120  allocate( answer_min( &
8121  & answer_shape(1), &
8122 
8123  & answer_shape(2), &
8124 
8125  & answer_shape(3), &
8126 
8127  & answer_shape(4) ) &
8128  & )
8129 
8130  answer_negative = answer < 0.0_dp
8131  check_negative = check < 0.0_dp
8132  both_negative = answer_negative .and. check_negative
8133 
8134  where (both_negative)
8135  answer_max = &
8136  & answer &
8137  & * ( 1.0_dp &
8138  & - 0.1_dp ** significant_digits ) &
8139  & + 0.1_dp ** (- ignore_digits)
8140 
8141  answer_min = &
8142  & answer &
8143  & * ( 1.0_dp &
8144  & + 0.1_dp ** significant_digits ) &
8145  & - 0.1_dp ** (- ignore_digits)
8146  elsewhere
8147  answer_max = &
8148  & answer &
8149  & * ( 1.0_dp &
8150  & + 0.1_dp ** significant_digits ) &
8151  & + 0.1_dp ** (- ignore_digits)
8152 
8153  answer_min = &
8154  & answer &
8155  & * ( 1.0_dp &
8156  & - 0.1_dp ** significant_digits ) &
8157  & - 0.1_dp ** (- ignore_digits)
8158  end where
8159 
8160  judge = answer_max > check .and. check > answer_min
8161  judge_rev = .not. judge
8162  err_flag = any(judge_rev)
8163  mask_array = 1
8164  pos = maxloc(mask_array, judge_rev)
8165 
8166  if (err_flag) then
8167 
8168  wrong = check( &
8169  & pos(1), &
8170 
8171  & pos(2), &
8172 
8173  & pos(3), &
8174 
8175  & pos(4) )
8176 
8177  right_max = answer_max( &
8178  & pos(1), &
8179 
8180  & pos(2), &
8181 
8182  & pos(3), &
8183 
8184  & pos(4) )
8185 
8186  right_min = answer_min( &
8187  & pos(1), &
8188 
8189  & pos(2), &
8190 
8191  & pos(3), &
8192 
8193  & pos(4) )
8194 
8195  if ( right_max < right_min ) then
8196  right_tmp = right_max
8197  right_max = right_min
8198  right_min = right_tmp
8199  end if
8200 
8201  write(unit=pos_array(1), fmt="(i20)") pos(1)
8202 
8203  write(unit=pos_array(2), fmt="(i20)") pos(2)
8204 
8205  write(unit=pos_array(3), fmt="(i20)") pos(3)
8206 
8207  write(unit=pos_array(4), fmt="(i20)") pos(4)
8208 
8209 
8210  pos_str = '(' // &
8211  & trim(adjustl(pos_array(1))) // ',' // &
8212 
8213  & trim(adjustl(pos_array(2))) // ',' // &
8214 
8215  & trim(adjustl(pos_array(3))) // ',' // &
8216 
8217  & trim(adjustl(pos_array(4))) // ')'
8218 
8219  end if
8220  deallocate(mask_array, judge, judge_rev)
8221  deallocate(answer_negative, check_negative, both_negative)
8222  deallocate(answer_max, answer_min)
8223 
8224 
8225 
8226  if (err_flag) then
8227  pos_str_space = ''
8228  pos_str_len = len_trim(pos_str)
8229 
8230  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8231  write(*,*) ''
8232  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8233  write(*,*) ' is NOT EQUAL to'
8234  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8235  & // ' ', right_min, ' < '
8236  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8237 
8238  call abortprogram('')
8239  else
8240  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8241  end if
8242 
8243 
8244  end subroutine dctestassertequaldouble4digits
8245 
8246 
8247  subroutine dctestassertequaldouble5digits( &
8248  & message, answer, check, significant_digits, ignore_digits )
8249  use sysdep, only: abortprogram
8250  use dc_types, only: string, token
8251  implicit none
8252  character(*), intent(in):: message
8253  real(DP), intent(in):: answer(:,:,:,:,:)
8254  real(DP), intent(in):: check(:,:,:,:,:)
8255  integer, intent(in):: significant_digits
8256  integer, intent(in):: ignore_digits
8257  logical:: err_flag
8258  character(STRING):: pos_str
8259  real(DP):: wrong, right_max, right_min
8260  character(STRING):: pos_str_space
8261  integer:: pos_str_len
8262  real(DP):: right_tmp
8263 
8264  integer:: answer_shape(5), check_shape(5), pos(5)
8265  logical:: consist_shape(5)
8266  character(TOKEN):: pos_array(5)
8267  integer, allocatable:: mask_array(:,:,:,:,:)
8268  logical, allocatable:: judge(:,:,:,:,:)
8269  logical, allocatable:: judge_rev(:,:,:,:,:)
8270  logical, allocatable:: answer_negative(:,:,:,:,:)
8271  logical, allocatable:: check_negative(:,:,:,:,:)
8272  logical, allocatable:: both_negative(:,:,:,:,:)
8273  real(DP), allocatable:: answer_max(:,:,:,:,:)
8274  real(DP), allocatable:: answer_min(:,:,:,:,:)
8275 
8276  continue
8277  err_flag = .false.
8278 
8279  if ( significant_digits < 1 ) then
8280  write(*,*) ' *** Error [AssertEQ] *** '
8281  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8282  call abortprogram('')
8283  end if
8284 
8285  answer_shape = shape(answer)
8286  check_shape = shape(check)
8287 
8288  consist_shape = answer_shape == check_shape
8289 
8290  if (.not. all(consist_shape)) then
8291  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8292  write(*,*) ''
8293  write(*,*) ' shape of check is (', check_shape, ')'
8294  write(*,*) ' is INCORRECT'
8295  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8296 
8297  call abortprogram('')
8298  end if
8299 
8300 
8301  allocate( mask_array( &
8302  & answer_shape(1), &
8303 
8304  & answer_shape(2), &
8305 
8306  & answer_shape(3), &
8307 
8308  & answer_shape(4), &
8309 
8310  & answer_shape(5) ) &
8311  & )
8312 
8313  allocate( judge( &
8314  & answer_shape(1), &
8315 
8316  & answer_shape(2), &
8317 
8318  & answer_shape(3), &
8319 
8320  & answer_shape(4), &
8321 
8322  & answer_shape(5) ) &
8323  & )
8324 
8325  allocate( judge_rev( &
8326  & answer_shape(1), &
8327 
8328  & answer_shape(2), &
8329 
8330  & answer_shape(3), &
8331 
8332  & answer_shape(4), &
8333 
8334  & answer_shape(5) ) &
8335  & )
8336 
8337  allocate( answer_negative( &
8338  & answer_shape(1), &
8339 
8340  & answer_shape(2), &
8341 
8342  & answer_shape(3), &
8343 
8344  & answer_shape(4), &
8345 
8346  & answer_shape(5) ) &
8347  & )
8348 
8349  allocate( check_negative( &
8350  & answer_shape(1), &
8351 
8352  & answer_shape(2), &
8353 
8354  & answer_shape(3), &
8355 
8356  & answer_shape(4), &
8357 
8358  & answer_shape(5) ) &
8359  & )
8360 
8361  allocate( both_negative( &
8362  & answer_shape(1), &
8363 
8364  & answer_shape(2), &
8365 
8366  & answer_shape(3), &
8367 
8368  & answer_shape(4), &
8369 
8370  & answer_shape(5) ) &
8371  & )
8372 
8373  allocate( answer_max( &
8374  & answer_shape(1), &
8375 
8376  & answer_shape(2), &
8377 
8378  & answer_shape(3), &
8379 
8380  & answer_shape(4), &
8381 
8382  & answer_shape(5) ) &
8383  & )
8384 
8385  allocate( answer_min( &
8386  & answer_shape(1), &
8387 
8388  & answer_shape(2), &
8389 
8390  & answer_shape(3), &
8391 
8392  & answer_shape(4), &
8393 
8394  & answer_shape(5) ) &
8395  & )
8396 
8397  answer_negative = answer < 0.0_dp
8398  check_negative = check < 0.0_dp
8399  both_negative = answer_negative .and. check_negative
8400 
8401  where (both_negative)
8402  answer_max = &
8403  & answer &
8404  & * ( 1.0_dp &
8405  & - 0.1_dp ** significant_digits ) &
8406  & + 0.1_dp ** (- ignore_digits)
8407 
8408  answer_min = &
8409  & answer &
8410  & * ( 1.0_dp &
8411  & + 0.1_dp ** significant_digits ) &
8412  & - 0.1_dp ** (- ignore_digits)
8413  elsewhere
8414  answer_max = &
8415  & answer &
8416  & * ( 1.0_dp &
8417  & + 0.1_dp ** significant_digits ) &
8418  & + 0.1_dp ** (- ignore_digits)
8419 
8420  answer_min = &
8421  & answer &
8422  & * ( 1.0_dp &
8423  & - 0.1_dp ** significant_digits ) &
8424  & - 0.1_dp ** (- ignore_digits)
8425  end where
8426 
8427  judge = answer_max > check .and. check > answer_min
8428  judge_rev = .not. judge
8429  err_flag = any(judge_rev)
8430  mask_array = 1
8431  pos = maxloc(mask_array, judge_rev)
8432 
8433  if (err_flag) then
8434 
8435  wrong = check( &
8436  & pos(1), &
8437 
8438  & pos(2), &
8439 
8440  & pos(3), &
8441 
8442  & pos(4), &
8443 
8444  & pos(5) )
8445 
8446  right_max = answer_max( &
8447  & pos(1), &
8448 
8449  & pos(2), &
8450 
8451  & pos(3), &
8452 
8453  & pos(4), &
8454 
8455  & pos(5) )
8456 
8457  right_min = answer_min( &
8458  & pos(1), &
8459 
8460  & pos(2), &
8461 
8462  & pos(3), &
8463 
8464  & pos(4), &
8465 
8466  & pos(5) )
8467 
8468  if ( right_max < right_min ) then
8469  right_tmp = right_max
8470  right_max = right_min
8471  right_min = right_tmp
8472  end if
8473 
8474  write(unit=pos_array(1), fmt="(i20)") pos(1)
8475 
8476  write(unit=pos_array(2), fmt="(i20)") pos(2)
8477 
8478  write(unit=pos_array(3), fmt="(i20)") pos(3)
8479 
8480  write(unit=pos_array(4), fmt="(i20)") pos(4)
8481 
8482  write(unit=pos_array(5), fmt="(i20)") pos(5)
8483 
8484 
8485  pos_str = '(' // &
8486  & trim(adjustl(pos_array(1))) // ',' // &
8487 
8488  & trim(adjustl(pos_array(2))) // ',' // &
8489 
8490  & trim(adjustl(pos_array(3))) // ',' // &
8491 
8492  & trim(adjustl(pos_array(4))) // ',' // &
8493 
8494  & trim(adjustl(pos_array(5))) // ')'
8495 
8496  end if
8497  deallocate(mask_array, judge, judge_rev)
8498  deallocate(answer_negative, check_negative, both_negative)
8499  deallocate(answer_max, answer_min)
8500 
8501 
8502 
8503  if (err_flag) then
8504  pos_str_space = ''
8505  pos_str_len = len_trim(pos_str)
8506 
8507  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8508  write(*,*) ''
8509  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8510  write(*,*) ' is NOT EQUAL to'
8511  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8512  & // ' ', right_min, ' < '
8513  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8514 
8515  call abortprogram('')
8516  else
8517  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8518  end if
8519 
8520 
8521  end subroutine dctestassertequaldouble5digits
8522 
8523 
8524  subroutine dctestassertequaldouble6digits( &
8525  & message, answer, check, significant_digits, ignore_digits )
8526  use sysdep, only: abortprogram
8527  use dc_types, only: string, token
8528  implicit none
8529  character(*), intent(in):: message
8530  real(DP), intent(in):: answer(:,:,:,:,:,:)
8531  real(DP), intent(in):: check(:,:,:,:,:,:)
8532  integer, intent(in):: significant_digits
8533  integer, intent(in):: ignore_digits
8534  logical:: err_flag
8535  character(STRING):: pos_str
8536  real(DP):: wrong, right_max, right_min
8537  character(STRING):: pos_str_space
8538  integer:: pos_str_len
8539  real(DP):: right_tmp
8540 
8541  integer:: answer_shape(6), check_shape(6), pos(6)
8542  logical:: consist_shape(6)
8543  character(TOKEN):: pos_array(6)
8544  integer, allocatable:: mask_array(:,:,:,:,:,:)
8545  logical, allocatable:: judge(:,:,:,:,:,:)
8546  logical, allocatable:: judge_rev(:,:,:,:,:,:)
8547  logical, allocatable:: answer_negative(:,:,:,:,:,:)
8548  logical, allocatable:: check_negative(:,:,:,:,:,:)
8549  logical, allocatable:: both_negative(:,:,:,:,:,:)
8550  real(DP), allocatable:: answer_max(:,:,:,:,:,:)
8551  real(DP), allocatable:: answer_min(:,:,:,:,:,:)
8552 
8553  continue
8554  err_flag = .false.
8555 
8556  if ( significant_digits < 1 ) then
8557  write(*,*) ' *** Error [AssertEQ] *** '
8558  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8559  call abortprogram('')
8560  end if
8561 
8562  answer_shape = shape(answer)
8563  check_shape = shape(check)
8564 
8565  consist_shape = answer_shape == check_shape
8566 
8567  if (.not. all(consist_shape)) then
8568  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8569  write(*,*) ''
8570  write(*,*) ' shape of check is (', check_shape, ')'
8571  write(*,*) ' is INCORRECT'
8572  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8573 
8574  call abortprogram('')
8575  end if
8576 
8577 
8578  allocate( mask_array( &
8579  & answer_shape(1), &
8580 
8581  & answer_shape(2), &
8582 
8583  & answer_shape(3), &
8584 
8585  & answer_shape(4), &
8586 
8587  & answer_shape(5), &
8588 
8589  & answer_shape(6) ) &
8590  & )
8591 
8592  allocate( judge( &
8593  & answer_shape(1), &
8594 
8595  & answer_shape(2), &
8596 
8597  & answer_shape(3), &
8598 
8599  & answer_shape(4), &
8600 
8601  & answer_shape(5), &
8602 
8603  & answer_shape(6) ) &
8604  & )
8605 
8606  allocate( judge_rev( &
8607  & answer_shape(1), &
8608 
8609  & answer_shape(2), &
8610 
8611  & answer_shape(3), &
8612 
8613  & answer_shape(4), &
8614 
8615  & answer_shape(5), &
8616 
8617  & answer_shape(6) ) &
8618  & )
8619 
8620  allocate( answer_negative( &
8621  & answer_shape(1), &
8622 
8623  & answer_shape(2), &
8624 
8625  & answer_shape(3), &
8626 
8627  & answer_shape(4), &
8628 
8629  & answer_shape(5), &
8630 
8631  & answer_shape(6) ) &
8632  & )
8633 
8634  allocate( check_negative( &
8635  & answer_shape(1), &
8636 
8637  & answer_shape(2), &
8638 
8639  & answer_shape(3), &
8640 
8641  & answer_shape(4), &
8642 
8643  & answer_shape(5), &
8644 
8645  & answer_shape(6) ) &
8646  & )
8647 
8648  allocate( both_negative( &
8649  & answer_shape(1), &
8650 
8651  & answer_shape(2), &
8652 
8653  & answer_shape(3), &
8654 
8655  & answer_shape(4), &
8656 
8657  & answer_shape(5), &
8658 
8659  & answer_shape(6) ) &
8660  & )
8661 
8662  allocate( answer_max( &
8663  & answer_shape(1), &
8664 
8665  & answer_shape(2), &
8666 
8667  & answer_shape(3), &
8668 
8669  & answer_shape(4), &
8670 
8671  & answer_shape(5), &
8672 
8673  & answer_shape(6) ) &
8674  & )
8675 
8676  allocate( answer_min( &
8677  & answer_shape(1), &
8678 
8679  & answer_shape(2), &
8680 
8681  & answer_shape(3), &
8682 
8683  & answer_shape(4), &
8684 
8685  & answer_shape(5), &
8686 
8687  & answer_shape(6) ) &
8688  & )
8689 
8690  answer_negative = answer < 0.0_dp
8691  check_negative = check < 0.0_dp
8692  both_negative = answer_negative .and. check_negative
8693 
8694  where (both_negative)
8695  answer_max = &
8696  & answer &
8697  & * ( 1.0_dp &
8698  & - 0.1_dp ** significant_digits ) &
8699  & + 0.1_dp ** (- ignore_digits)
8700 
8701  answer_min = &
8702  & answer &
8703  & * ( 1.0_dp &
8704  & + 0.1_dp ** significant_digits ) &
8705  & - 0.1_dp ** (- ignore_digits)
8706  elsewhere
8707  answer_max = &
8708  & answer &
8709  & * ( 1.0_dp &
8710  & + 0.1_dp ** significant_digits ) &
8711  & + 0.1_dp ** (- ignore_digits)
8712 
8713  answer_min = &
8714  & answer &
8715  & * ( 1.0_dp &
8716  & - 0.1_dp ** significant_digits ) &
8717  & - 0.1_dp ** (- ignore_digits)
8718  end where
8719 
8720  judge = answer_max > check .and. check > answer_min
8721  judge_rev = .not. judge
8722  err_flag = any(judge_rev)
8723  mask_array = 1
8724  pos = maxloc(mask_array, judge_rev)
8725 
8726  if (err_flag) then
8727 
8728  wrong = check( &
8729  & pos(1), &
8730 
8731  & pos(2), &
8732 
8733  & pos(3), &
8734 
8735  & pos(4), &
8736 
8737  & pos(5), &
8738 
8739  & pos(6) )
8740 
8741  right_max = answer_max( &
8742  & pos(1), &
8743 
8744  & pos(2), &
8745 
8746  & pos(3), &
8747 
8748  & pos(4), &
8749 
8750  & pos(5), &
8751 
8752  & pos(6) )
8753 
8754  right_min = answer_min( &
8755  & pos(1), &
8756 
8757  & pos(2), &
8758 
8759  & pos(3), &
8760 
8761  & pos(4), &
8762 
8763  & pos(5), &
8764 
8765  & pos(6) )
8766 
8767  if ( right_max < right_min ) then
8768  right_tmp = right_max
8769  right_max = right_min
8770  right_min = right_tmp
8771  end if
8772 
8773  write(unit=pos_array(1), fmt="(i20)") pos(1)
8774 
8775  write(unit=pos_array(2), fmt="(i20)") pos(2)
8776 
8777  write(unit=pos_array(3), fmt="(i20)") pos(3)
8778 
8779  write(unit=pos_array(4), fmt="(i20)") pos(4)
8780 
8781  write(unit=pos_array(5), fmt="(i20)") pos(5)
8782 
8783  write(unit=pos_array(6), fmt="(i20)") pos(6)
8784 
8785 
8786  pos_str = '(' // &
8787  & trim(adjustl(pos_array(1))) // ',' // &
8788 
8789  & trim(adjustl(pos_array(2))) // ',' // &
8790 
8791  & trim(adjustl(pos_array(3))) // ',' // &
8792 
8793  & trim(adjustl(pos_array(4))) // ',' // &
8794 
8795  & trim(adjustl(pos_array(5))) // ',' // &
8796 
8797  & trim(adjustl(pos_array(6))) // ')'
8798 
8799  end if
8800  deallocate(mask_array, judge, judge_rev)
8801  deallocate(answer_negative, check_negative, both_negative)
8802  deallocate(answer_max, answer_min)
8803 
8804 
8805 
8806  if (err_flag) then
8807  pos_str_space = ''
8808  pos_str_len = len_trim(pos_str)
8809 
8810  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8811  write(*,*) ''
8812  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8813  write(*,*) ' is NOT EQUAL to'
8814  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8815  & // ' ', right_min, ' < '
8816  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8817 
8818  call abortprogram('')
8819  else
8820  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8821  end if
8822 
8823 
8824  end subroutine dctestassertequaldouble6digits
8825 
8826 
8827  subroutine dctestassertequaldouble7digits( &
8828  & message, answer, check, significant_digits, ignore_digits )
8829  use sysdep, only: abortprogram
8830  use dc_types, only: string, token
8831  implicit none
8832  character(*), intent(in):: message
8833  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
8834  real(DP), intent(in):: check(:,:,:,:,:,:,:)
8835  integer, intent(in):: significant_digits
8836  integer, intent(in):: ignore_digits
8837  logical:: err_flag
8838  character(STRING):: pos_str
8839  real(DP):: wrong, right_max, right_min
8840  character(STRING):: pos_str_space
8841  integer:: pos_str_len
8842  real(DP):: right_tmp
8843 
8844  integer:: answer_shape(7), check_shape(7), pos(7)
8845  logical:: consist_shape(7)
8846  character(TOKEN):: pos_array(7)
8847  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
8848  logical, allocatable:: judge(:,:,:,:,:,:,:)
8849  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
8850  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
8851  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
8852  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
8853  real(DP), allocatable:: answer_max(:,:,:,:,:,:,:)
8854  real(DP), allocatable:: answer_min(:,:,:,:,:,:,:)
8855 
8856  continue
8857  err_flag = .false.
8858 
8859  if ( significant_digits < 1 ) then
8860  write(*,*) ' *** Error [AssertEQ] *** '
8861  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8862  call abortprogram('')
8863  end if
8864 
8865  answer_shape = shape(answer)
8866  check_shape = shape(check)
8867 
8868  consist_shape = answer_shape == check_shape
8869 
8870  if (.not. all(consist_shape)) then
8871  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8872  write(*,*) ''
8873  write(*,*) ' shape of check is (', check_shape, ')'
8874  write(*,*) ' is INCORRECT'
8875  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8876 
8877  call abortprogram('')
8878  end if
8879 
8880 
8881  allocate( mask_array( &
8882  & answer_shape(1), &
8883 
8884  & answer_shape(2), &
8885 
8886  & answer_shape(3), &
8887 
8888  & answer_shape(4), &
8889 
8890  & answer_shape(5), &
8891 
8892  & answer_shape(6), &
8893 
8894  & answer_shape(7) ) &
8895  & )
8896 
8897  allocate( judge( &
8898  & answer_shape(1), &
8899 
8900  & answer_shape(2), &
8901 
8902  & answer_shape(3), &
8903 
8904  & answer_shape(4), &
8905 
8906  & answer_shape(5), &
8907 
8908  & answer_shape(6), &
8909 
8910  & answer_shape(7) ) &
8911  & )
8912 
8913  allocate( judge_rev( &
8914  & answer_shape(1), &
8915 
8916  & answer_shape(2), &
8917 
8918  & answer_shape(3), &
8919 
8920  & answer_shape(4), &
8921 
8922  & answer_shape(5), &
8923 
8924  & answer_shape(6), &
8925 
8926  & answer_shape(7) ) &
8927  & )
8928 
8929  allocate( answer_negative( &
8930  & answer_shape(1), &
8931 
8932  & answer_shape(2), &
8933 
8934  & answer_shape(3), &
8935 
8936  & answer_shape(4), &
8937 
8938  & answer_shape(5), &
8939 
8940  & answer_shape(6), &
8941 
8942  & answer_shape(7) ) &
8943  & )
8944 
8945  allocate( check_negative( &
8946  & answer_shape(1), &
8947 
8948  & answer_shape(2), &
8949 
8950  & answer_shape(3), &
8951 
8952  & answer_shape(4), &
8953 
8954  & answer_shape(5), &
8955 
8956  & answer_shape(6), &
8957 
8958  & answer_shape(7) ) &
8959  & )
8960 
8961  allocate( both_negative( &
8962  & answer_shape(1), &
8963 
8964  & answer_shape(2), &
8965 
8966  & answer_shape(3), &
8967 
8968  & answer_shape(4), &
8969 
8970  & answer_shape(5), &
8971 
8972  & answer_shape(6), &
8973 
8974  & answer_shape(7) ) &
8975  & )
8976 
8977  allocate( answer_max( &
8978  & answer_shape(1), &
8979 
8980  & answer_shape(2), &
8981 
8982  & answer_shape(3), &
8983 
8984  & answer_shape(4), &
8985 
8986  & answer_shape(5), &
8987 
8988  & answer_shape(6), &
8989 
8990  & answer_shape(7) ) &
8991  & )
8992 
8993  allocate( answer_min( &
8994  & answer_shape(1), &
8995 
8996  & answer_shape(2), &
8997 
8998  & answer_shape(3), &
8999 
9000  & answer_shape(4), &
9001 
9002  & answer_shape(5), &
9003 
9004  & answer_shape(6), &
9005 
9006  & answer_shape(7) ) &
9007  & )
9008 
9009  answer_negative = answer < 0.0_dp
9010  check_negative = check < 0.0_dp
9011  both_negative = answer_negative .and. check_negative
9012 
9013  where (both_negative)
9014  answer_max = &
9015  & answer &
9016  & * ( 1.0_dp &
9017  & - 0.1_dp ** significant_digits ) &
9018  & + 0.1_dp ** (- ignore_digits)
9019 
9020  answer_min = &
9021  & answer &
9022  & * ( 1.0_dp &
9023  & + 0.1_dp ** significant_digits ) &
9024  & - 0.1_dp ** (- ignore_digits)
9025  elsewhere
9026  answer_max = &
9027  & answer &
9028  & * ( 1.0_dp &
9029  & + 0.1_dp ** significant_digits ) &
9030  & + 0.1_dp ** (- ignore_digits)
9031 
9032  answer_min = &
9033  & answer &
9034  & * ( 1.0_dp &
9035  & - 0.1_dp ** significant_digits ) &
9036  & - 0.1_dp ** (- ignore_digits)
9037  end where
9038 
9039  judge = answer_max > check .and. check > answer_min
9040  judge_rev = .not. judge
9041  err_flag = any(judge_rev)
9042  mask_array = 1
9043  pos = maxloc(mask_array, judge_rev)
9044 
9045  if (err_flag) then
9046 
9047  wrong = check( &
9048  & pos(1), &
9049 
9050  & pos(2), &
9051 
9052  & pos(3), &
9053 
9054  & pos(4), &
9055 
9056  & pos(5), &
9057 
9058  & pos(6), &
9059 
9060  & pos(7) )
9061 
9062  right_max = answer_max( &
9063  & pos(1), &
9064 
9065  & pos(2), &
9066 
9067  & pos(3), &
9068 
9069  & pos(4), &
9070 
9071  & pos(5), &
9072 
9073  & pos(6), &
9074 
9075  & pos(7) )
9076 
9077  right_min = answer_min( &
9078  & pos(1), &
9079 
9080  & pos(2), &
9081 
9082  & pos(3), &
9083 
9084  & pos(4), &
9085 
9086  & pos(5), &
9087 
9088  & pos(6), &
9089 
9090  & pos(7) )
9091 
9092  if ( right_max < right_min ) then
9093  right_tmp = right_max
9094  right_max = right_min
9095  right_min = right_tmp
9096  end if
9097 
9098  write(unit=pos_array(1), fmt="(i20)") pos(1)
9099 
9100  write(unit=pos_array(2), fmt="(i20)") pos(2)
9101 
9102  write(unit=pos_array(3), fmt="(i20)") pos(3)
9103 
9104  write(unit=pos_array(4), fmt="(i20)") pos(4)
9105 
9106  write(unit=pos_array(5), fmt="(i20)") pos(5)
9107 
9108  write(unit=pos_array(6), fmt="(i20)") pos(6)
9109 
9110  write(unit=pos_array(7), fmt="(i20)") pos(7)
9111 
9112 
9113  pos_str = '(' // &
9114  & trim(adjustl(pos_array(1))) // ',' // &
9115 
9116  & trim(adjustl(pos_array(2))) // ',' // &
9117 
9118  & trim(adjustl(pos_array(3))) // ',' // &
9119 
9120  & trim(adjustl(pos_array(4))) // ',' // &
9121 
9122  & trim(adjustl(pos_array(5))) // ',' // &
9123 
9124  & trim(adjustl(pos_array(6))) // ',' // &
9125 
9126  & trim(adjustl(pos_array(7))) // ')'
9127 
9128  end if
9129  deallocate(mask_array, judge, judge_rev)
9130  deallocate(answer_negative, check_negative, both_negative)
9131  deallocate(answer_max, answer_min)
9132 
9133 
9134 
9135  if (err_flag) then
9136  pos_str_space = ''
9137  pos_str_len = len_trim(pos_str)
9138 
9139  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
9140  write(*,*) ''
9141  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
9142  write(*,*) ' is NOT EQUAL to'
9143  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
9144  & // ' ', right_min, ' < '
9145  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
9146 
9147  call abortprogram('')
9148  else
9149  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
9150  end if
9151 
9152 
9153  end subroutine dctestassertequaldouble7digits
9154 
9155 
9156  subroutine dctestassertgreaterthanint0( &
9157  & message, answer, check, negative_support)
9158  use sysdep, only: abortprogram
9159  use dc_types, only: string, token
9160  implicit none
9161  character(*), intent(in):: message
9162  integer, intent(in):: answer
9163  integer, intent(in):: check
9164  logical, intent(in), optional:: negative_support
9165  logical:: err_flag
9166  logical:: negative_support_on
9167  character(STRING):: pos_str
9168  character(TOKEN):: abs_mes
9169  integer:: wrong, right
9170 
9171 
9172 
9173  continue
9174  if (present(negative_support)) then
9175  negative_support_on = negative_support
9176  else
9177  negative_support_on = .true.
9178  end if
9179 
9180  err_flag = .false.
9181 
9182 
9183  err_flag = .not. answer < check
9184  abs_mes = ''
9185 
9186  if ( answer < 0 &
9187  & .and. check < 0 &
9188  & .and. negative_support_on ) then
9189 
9190  err_flag = .not. err_flag
9191  abs_mes = 'ABSOLUTE value of'
9192  end if
9193 
9194  wrong = check
9195  right = answer
9196  pos_str = ''
9197 
9198 
9199 
9200 
9201  if (err_flag) then
9202  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9203  write(*,*) ''
9204  write(*,*) ' ' // trim(abs_mes) // &
9205  & ' check' // trim(pos_str) // ' = ', wrong
9206  write(*,*) ' is NOT GREATER THAN'
9207  write(*,*) ' ' // trim(abs_mes) // &
9208  & ' answer' // trim(pos_str) // ' = ', right
9209 
9210  call abortprogram('')
9211  else
9212  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9213  end if
9214 
9215 
9216  end subroutine dctestassertgreaterthanint0
9217 
9218 
9219  subroutine dctestassertgreaterthanint1( &
9220  & message, answer, check, negative_support)
9221  use sysdep, only: abortprogram
9222  use dc_types, only: string, token
9223  implicit none
9224  character(*), intent(in):: message
9225  integer, intent(in):: answer(:)
9226  integer, intent(in):: check(:)
9227  logical, intent(in), optional:: negative_support
9228  logical:: err_flag
9229  logical:: negative_support_on
9230  character(STRING):: pos_str
9231  character(TOKEN):: abs_mes
9232  integer:: wrong, right
9233 
9234  integer:: answer_shape(1), check_shape(1), pos(1)
9235  logical:: consist_shape(1)
9236  character(TOKEN):: pos_array(1)
9237  integer, allocatable:: mask_array(:)
9238  logical, allocatable:: judge(:)
9239  logical, allocatable:: judge_rev(:)
9240  logical, allocatable:: answer_negative(:)
9241  logical, allocatable:: check_negative(:)
9242  logical, allocatable:: both_negative(:)
9243 
9244 
9245  continue
9246  if (present(negative_support)) then
9247  negative_support_on = negative_support
9248  else
9249  negative_support_on = .true.
9250  end if
9251 
9252  err_flag = .false.
9253 
9254 
9255  answer_shape = shape(answer)
9256  check_shape = shape(check)
9257 
9258  consist_shape = answer_shape == check_shape
9259 
9260  if (.not. all(consist_shape)) then
9261  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9262  write(*,*) ''
9263  write(*,*) ' shape of check is (', check_shape, ')'
9264  write(*,*) ' is INCORRECT'
9265  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9266 
9267  call abortprogram('')
9268  end if
9269 
9270 
9271  allocate( mask_array( &
9272 
9273  & answer_shape(1) ) &
9274  & )
9275 
9276  allocate( judge( &
9277 
9278  & answer_shape(1) ) &
9279  & )
9280 
9281  allocate( judge_rev( &
9282 
9283  & answer_shape(1) ) &
9284  & )
9285 
9286  allocate( answer_negative( &
9287 
9288  & answer_shape(1) ) &
9289  & )
9290 
9291  allocate( check_negative( &
9292 
9293  & answer_shape(1) ) &
9294  & )
9295 
9296  allocate( both_negative( &
9297 
9298  & answer_shape(1) ) &
9299  & )
9300 
9301  answer_negative = answer < 0
9302  check_negative = check < 0
9303  both_negative = answer_negative .and. check_negative
9304  if (.not. negative_support_on) both_negative = .false.
9305 
9306  judge = answer < check
9307  where (both_negative) judge = .not. judge
9308 
9309  judge_rev = .not. judge
9310  err_flag = any(judge_rev)
9311  mask_array = 1
9312  pos = maxloc(mask_array, judge_rev)
9313 
9314  if (err_flag) then
9315 
9316  wrong = check( &
9317 
9318  & pos(1) )
9319 
9320  right = answer( &
9321 
9322  & pos(1) )
9323 
9324  write(unit=pos_array(1), fmt="(i20)") pos(1)
9325 
9326 
9327  pos_str = '(' // &
9328 
9329  & trim(adjustl(pos_array(1))) // ')'
9330 
9331  if ( both_negative( &
9332 
9333  & pos(1) ) ) then
9334 
9335  abs_mes = 'ABSOLUTE value of'
9336  else
9337  abs_mes = ''
9338 
9339  end if
9340 
9341  end if
9342  deallocate(mask_array, judge, judge_rev)
9343  deallocate(answer_negative, check_negative, both_negative)
9344 
9345 
9346 
9347 
9348  if (err_flag) then
9349  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9350  write(*,*) ''
9351  write(*,*) ' ' // trim(abs_mes) // &
9352  & ' check' // trim(pos_str) // ' = ', wrong
9353  write(*,*) ' is NOT GREATER THAN'
9354  write(*,*) ' ' // trim(abs_mes) // &
9355  & ' answer' // trim(pos_str) // ' = ', right
9356 
9357  call abortprogram('')
9358  else
9359  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9360  end if
9361 
9362 
9363  end subroutine dctestassertgreaterthanint1
9364 
9365 
9366  subroutine dctestassertgreaterthanint2( &
9367  & message, answer, check, negative_support)
9368  use sysdep, only: abortprogram
9369  use dc_types, only: string, token
9370  implicit none
9371  character(*), intent(in):: message
9372  integer, intent(in):: answer(:,:)
9373  integer, intent(in):: check(:,:)
9374  logical, intent(in), optional:: negative_support
9375  logical:: err_flag
9376  logical:: negative_support_on
9377  character(STRING):: pos_str
9378  character(TOKEN):: abs_mes
9379  integer:: wrong, right
9380 
9381  integer:: answer_shape(2), check_shape(2), pos(2)
9382  logical:: consist_shape(2)
9383  character(TOKEN):: pos_array(2)
9384  integer, allocatable:: mask_array(:,:)
9385  logical, allocatable:: judge(:,:)
9386  logical, allocatable:: judge_rev(:,:)
9387  logical, allocatable:: answer_negative(:,:)
9388  logical, allocatable:: check_negative(:,:)
9389  logical, allocatable:: both_negative(:,:)
9390 
9391 
9392  continue
9393  if (present(negative_support)) then
9394  negative_support_on = negative_support
9395  else
9396  negative_support_on = .true.
9397  end if
9398 
9399  err_flag = .false.
9400 
9401 
9402  answer_shape = shape(answer)
9403  check_shape = shape(check)
9404 
9405  consist_shape = answer_shape == check_shape
9406 
9407  if (.not. all(consist_shape)) then
9408  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9409  write(*,*) ''
9410  write(*,*) ' shape of check is (', check_shape, ')'
9411  write(*,*) ' is INCORRECT'
9412  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9413 
9414  call abortprogram('')
9415  end if
9416 
9417 
9418  allocate( mask_array( &
9419  & answer_shape(1), &
9420 
9421  & answer_shape(2) ) &
9422  & )
9423 
9424  allocate( judge( &
9425  & answer_shape(1), &
9426 
9427  & answer_shape(2) ) &
9428  & )
9429 
9430  allocate( judge_rev( &
9431  & answer_shape(1), &
9432 
9433  & answer_shape(2) ) &
9434  & )
9435 
9436  allocate( answer_negative( &
9437  & answer_shape(1), &
9438 
9439  & answer_shape(2) ) &
9440  & )
9441 
9442  allocate( check_negative( &
9443  & answer_shape(1), &
9444 
9445  & answer_shape(2) ) &
9446  & )
9447 
9448  allocate( both_negative( &
9449  & answer_shape(1), &
9450 
9451  & answer_shape(2) ) &
9452  & )
9453 
9454  answer_negative = answer < 0
9455  check_negative = check < 0
9456  both_negative = answer_negative .and. check_negative
9457  if (.not. negative_support_on) both_negative = .false.
9458 
9459  judge = answer < check
9460  where (both_negative) judge = .not. judge
9461 
9462  judge_rev = .not. judge
9463  err_flag = any(judge_rev)
9464  mask_array = 1
9465  pos = maxloc(mask_array, judge_rev)
9466 
9467  if (err_flag) then
9468 
9469  wrong = check( &
9470  & pos(1), &
9471 
9472  & pos(2) )
9473 
9474  right = answer( &
9475  & pos(1), &
9476 
9477  & pos(2) )
9478 
9479  write(unit=pos_array(1), fmt="(i20)") pos(1)
9480 
9481  write(unit=pos_array(2), fmt="(i20)") pos(2)
9482 
9483 
9484  pos_str = '(' // &
9485  & trim(adjustl(pos_array(1))) // ',' // &
9486 
9487  & trim(adjustl(pos_array(2))) // ')'
9488 
9489  if ( both_negative( &
9490  & pos(1), &
9491 
9492  & pos(2) ) ) then
9493 
9494  abs_mes = 'ABSOLUTE value of'
9495  else
9496  abs_mes = ''
9497 
9498  end if
9499 
9500  end if
9501  deallocate(mask_array, judge, judge_rev)
9502  deallocate(answer_negative, check_negative, both_negative)
9503 
9504 
9505 
9506 
9507  if (err_flag) then
9508  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9509  write(*,*) ''
9510  write(*,*) ' ' // trim(abs_mes) // &
9511  & ' check' // trim(pos_str) // ' = ', wrong
9512  write(*,*) ' is NOT GREATER THAN'
9513  write(*,*) ' ' // trim(abs_mes) // &
9514  & ' answer' // trim(pos_str) // ' = ', right
9515 
9516  call abortprogram('')
9517  else
9518  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9519  end if
9520 
9521 
9522  end subroutine dctestassertgreaterthanint2
9523 
9524 
9525  subroutine dctestassertgreaterthanint3( &
9526  & message, answer, check, negative_support)
9527  use sysdep, only: abortprogram
9528  use dc_types, only: string, token
9529  implicit none
9530  character(*), intent(in):: message
9531  integer, intent(in):: answer(:,:,:)
9532  integer, intent(in):: check(:,:,:)
9533  logical, intent(in), optional:: negative_support
9534  logical:: err_flag
9535  logical:: negative_support_on
9536  character(STRING):: pos_str
9537  character(TOKEN):: abs_mes
9538  integer:: wrong, right
9539 
9540  integer:: answer_shape(3), check_shape(3), pos(3)
9541  logical:: consist_shape(3)
9542  character(TOKEN):: pos_array(3)
9543  integer, allocatable:: mask_array(:,:,:)
9544  logical, allocatable:: judge(:,:,:)
9545  logical, allocatable:: judge_rev(:,:,:)
9546  logical, allocatable:: answer_negative(:,:,:)
9547  logical, allocatable:: check_negative(:,:,:)
9548  logical, allocatable:: both_negative(:,:,:)
9549 
9550 
9551  continue
9552  if (present(negative_support)) then
9553  negative_support_on = negative_support
9554  else
9555  negative_support_on = .true.
9556  end if
9557 
9558  err_flag = .false.
9559 
9560 
9561  answer_shape = shape(answer)
9562  check_shape = shape(check)
9563 
9564  consist_shape = answer_shape == check_shape
9565 
9566  if (.not. all(consist_shape)) then
9567  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9568  write(*,*) ''
9569  write(*,*) ' shape of check is (', check_shape, ')'
9570  write(*,*) ' is INCORRECT'
9571  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9572 
9573  call abortprogram('')
9574  end if
9575 
9576 
9577  allocate( mask_array( &
9578  & answer_shape(1), &
9579 
9580  & answer_shape(2), &
9581 
9582  & answer_shape(3) ) &
9583  & )
9584 
9585  allocate( judge( &
9586  & answer_shape(1), &
9587 
9588  & answer_shape(2), &
9589 
9590  & answer_shape(3) ) &
9591  & )
9592 
9593  allocate( judge_rev( &
9594  & answer_shape(1), &
9595 
9596  & answer_shape(2), &
9597 
9598  & answer_shape(3) ) &
9599  & )
9600 
9601  allocate( answer_negative( &
9602  & answer_shape(1), &
9603 
9604  & answer_shape(2), &
9605 
9606  & answer_shape(3) ) &
9607  & )
9608 
9609  allocate( check_negative( &
9610  & answer_shape(1), &
9611 
9612  & answer_shape(2), &
9613 
9614  & answer_shape(3) ) &
9615  & )
9616 
9617  allocate( both_negative( &
9618  & answer_shape(1), &
9619 
9620  & answer_shape(2), &
9621 
9622  & answer_shape(3) ) &
9623  & )
9624 
9625  answer_negative = answer < 0
9626  check_negative = check < 0
9627  both_negative = answer_negative .and. check_negative
9628  if (.not. negative_support_on) both_negative = .false.
9629 
9630  judge = answer < check
9631  where (both_negative) judge = .not. judge
9632 
9633  judge_rev = .not. judge
9634  err_flag = any(judge_rev)
9635  mask_array = 1
9636  pos = maxloc(mask_array, judge_rev)
9637 
9638  if (err_flag) then
9639 
9640  wrong = check( &
9641  & pos(1), &
9642 
9643  & pos(2), &
9644 
9645  & pos(3) )
9646 
9647  right = answer( &
9648  & pos(1), &
9649 
9650  & pos(2), &
9651 
9652  & pos(3) )
9653 
9654  write(unit=pos_array(1), fmt="(i20)") pos(1)
9655 
9656  write(unit=pos_array(2), fmt="(i20)") pos(2)
9657 
9658  write(unit=pos_array(3), fmt="(i20)") pos(3)
9659 
9660 
9661  pos_str = '(' // &
9662  & trim(adjustl(pos_array(1))) // ',' // &
9663 
9664  & trim(adjustl(pos_array(2))) // ',' // &
9665 
9666  & trim(adjustl(pos_array(3))) // ')'
9667 
9668  if ( both_negative( &
9669  & pos(1), &
9670 
9671  & pos(2), &
9672 
9673  & pos(3) ) ) then
9674 
9675  abs_mes = 'ABSOLUTE value of'
9676  else
9677  abs_mes = ''
9678 
9679  end if
9680 
9681  end if
9682  deallocate(mask_array, judge, judge_rev)
9683  deallocate(answer_negative, check_negative, both_negative)
9684 
9685 
9686 
9687 
9688  if (err_flag) then
9689  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9690  write(*,*) ''
9691  write(*,*) ' ' // trim(abs_mes) // &
9692  & ' check' // trim(pos_str) // ' = ', wrong
9693  write(*,*) ' is NOT GREATER THAN'
9694  write(*,*) ' ' // trim(abs_mes) // &
9695  & ' answer' // trim(pos_str) // ' = ', right
9696 
9697  call abortprogram('')
9698  else
9699  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9700  end if
9701 
9702 
9703  end subroutine dctestassertgreaterthanint3
9704 
9705 
9706  subroutine dctestassertgreaterthanint4( &
9707  & message, answer, check, negative_support)
9708  use sysdep, only: abortprogram
9709  use dc_types, only: string, token
9710  implicit none
9711  character(*), intent(in):: message
9712  integer, intent(in):: answer(:,:,:,:)
9713  integer, intent(in):: check(:,:,:,:)
9714  logical, intent(in), optional:: negative_support
9715  logical:: err_flag
9716  logical:: negative_support_on
9717  character(STRING):: pos_str
9718  character(TOKEN):: abs_mes
9719  integer:: wrong, right
9720 
9721  integer:: answer_shape(4), check_shape(4), pos(4)
9722  logical:: consist_shape(4)
9723  character(TOKEN):: pos_array(4)
9724  integer, allocatable:: mask_array(:,:,:,:)
9725  logical, allocatable:: judge(:,:,:,:)
9726  logical, allocatable:: judge_rev(:,:,:,:)
9727  logical, allocatable:: answer_negative(:,:,:,:)
9728  logical, allocatable:: check_negative(:,:,:,:)
9729  logical, allocatable:: both_negative(:,:,:,:)
9730 
9731 
9732  continue
9733  if (present(negative_support)) then
9734  negative_support_on = negative_support
9735  else
9736  negative_support_on = .true.
9737  end if
9738 
9739  err_flag = .false.
9740 
9741 
9742  answer_shape = shape(answer)
9743  check_shape = shape(check)
9744 
9745  consist_shape = answer_shape == check_shape
9746 
9747  if (.not. all(consist_shape)) then
9748  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9749  write(*,*) ''
9750  write(*,*) ' shape of check is (', check_shape, ')'
9751  write(*,*) ' is INCORRECT'
9752  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9753 
9754  call abortprogram('')
9755  end if
9756 
9757 
9758  allocate( mask_array( &
9759  & answer_shape(1), &
9760 
9761  & answer_shape(2), &
9762 
9763  & answer_shape(3), &
9764 
9765  & answer_shape(4) ) &
9766  & )
9767 
9768  allocate( judge( &
9769  & answer_shape(1), &
9770 
9771  & answer_shape(2), &
9772 
9773  & answer_shape(3), &
9774 
9775  & answer_shape(4) ) &
9776  & )
9777 
9778  allocate( judge_rev( &
9779  & answer_shape(1), &
9780 
9781  & answer_shape(2), &
9782 
9783  & answer_shape(3), &
9784 
9785  & answer_shape(4) ) &
9786  & )
9787 
9788  allocate( answer_negative( &
9789  & answer_shape(1), &
9790 
9791  & answer_shape(2), &
9792 
9793  & answer_shape(3), &
9794 
9795  & answer_shape(4) ) &
9796  & )
9797 
9798  allocate( check_negative( &
9799  & answer_shape(1), &
9800 
9801  & answer_shape(2), &
9802 
9803  & answer_shape(3), &
9804 
9805  & answer_shape(4) ) &
9806  & )
9807 
9808  allocate( both_negative( &
9809  & answer_shape(1), &
9810 
9811  & answer_shape(2), &
9812 
9813  & answer_shape(3), &
9814 
9815  & answer_shape(4) ) &
9816  & )
9817 
9818  answer_negative = answer < 0
9819  check_negative = check < 0
9820  both_negative = answer_negative .and. check_negative
9821  if (.not. negative_support_on) both_negative = .false.
9822 
9823  judge = answer < check
9824  where (both_negative) judge = .not. judge
9825 
9826  judge_rev = .not. judge
9827  err_flag = any(judge_rev)
9828  mask_array = 1
9829  pos = maxloc(mask_array, judge_rev)
9830 
9831  if (err_flag) then
9832 
9833  wrong = check( &
9834  & pos(1), &
9835 
9836  & pos(2), &
9837 
9838  & pos(3), &
9839 
9840  & pos(4) )
9841 
9842  right = answer( &
9843  & pos(1), &
9844 
9845  & pos(2), &
9846 
9847  & pos(3), &
9848 
9849  & pos(4) )
9850 
9851  write(unit=pos_array(1), fmt="(i20)") pos(1)
9852 
9853  write(unit=pos_array(2), fmt="(i20)") pos(2)
9854 
9855  write(unit=pos_array(3), fmt="(i20)") pos(3)
9856 
9857  write(unit=pos_array(4), fmt="(i20)") pos(4)
9858 
9859 
9860  pos_str = '(' // &
9861  & trim(adjustl(pos_array(1))) // ',' // &
9862 
9863  & trim(adjustl(pos_array(2))) // ',' // &
9864 
9865  & trim(adjustl(pos_array(3))) // ',' // &
9866 
9867  & trim(adjustl(pos_array(4))) // ')'
9868 
9869  if ( both_negative( &
9870  & pos(1), &
9871 
9872  & pos(2), &
9873 
9874  & pos(3), &
9875 
9876  & pos(4) ) ) then
9877 
9878  abs_mes = 'ABSOLUTE value of'
9879  else
9880  abs_mes = ''
9881 
9882  end if
9883 
9884  end if
9885  deallocate(mask_array, judge, judge_rev)
9886  deallocate(answer_negative, check_negative, both_negative)
9887 
9888 
9889 
9890 
9891  if (err_flag) then
9892  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9893  write(*,*) ''
9894  write(*,*) ' ' // trim(abs_mes) // &
9895  & ' check' // trim(pos_str) // ' = ', wrong
9896  write(*,*) ' is NOT GREATER THAN'
9897  write(*,*) ' ' // trim(abs_mes) // &
9898  & ' answer' // trim(pos_str) // ' = ', right
9899 
9900  call abortprogram('')
9901  else
9902  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9903  end if
9904 
9905 
9906  end subroutine dctestassertgreaterthanint4
9907 
9908 
9909  subroutine dctestassertgreaterthanint5( &
9910  & message, answer, check, negative_support)
9911  use sysdep, only: abortprogram
9912  use dc_types, only: string, token
9913  implicit none
9914  character(*), intent(in):: message
9915  integer, intent(in):: answer(:,:,:,:,:)
9916  integer, intent(in):: check(:,:,:,:,:)
9917  logical, intent(in), optional:: negative_support
9918  logical:: err_flag
9919  logical:: negative_support_on
9920  character(STRING):: pos_str
9921  character(TOKEN):: abs_mes
9922  integer:: wrong, right
9923 
9924  integer:: answer_shape(5), check_shape(5), pos(5)
9925  logical:: consist_shape(5)
9926  character(TOKEN):: pos_array(5)
9927  integer, allocatable:: mask_array(:,:,:,:,:)
9928  logical, allocatable:: judge(:,:,:,:,:)
9929  logical, allocatable:: judge_rev(:,:,:,:,:)
9930  logical, allocatable:: answer_negative(:,:,:,:,:)
9931  logical, allocatable:: check_negative(:,:,:,:,:)
9932  logical, allocatable:: both_negative(:,:,:,:,:)
9933 
9934 
9935  continue
9936  if (present(negative_support)) then
9937  negative_support_on = negative_support
9938  else
9939  negative_support_on = .true.
9940  end if
9941 
9942  err_flag = .false.
9943 
9944 
9945  answer_shape = shape(answer)
9946  check_shape = shape(check)
9947 
9948  consist_shape = answer_shape == check_shape
9949 
9950  if (.not. all(consist_shape)) then
9951  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9952  write(*,*) ''
9953  write(*,*) ' shape of check is (', check_shape, ')'
9954  write(*,*) ' is INCORRECT'
9955  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9956 
9957  call abortprogram('')
9958  end if
9959 
9960 
9961  allocate( mask_array( &
9962  & answer_shape(1), &
9963 
9964  & answer_shape(2), &
9965 
9966  & answer_shape(3), &
9967 
9968  & answer_shape(4), &
9969 
9970  & answer_shape(5) ) &
9971  & )
9972 
9973  allocate( judge( &
9974  & answer_shape(1), &
9975 
9976  & answer_shape(2), &
9977 
9978  & answer_shape(3), &
9979 
9980  & answer_shape(4), &
9981 
9982  & answer_shape(5) ) &
9983  & )
9984 
9985  allocate( judge_rev( &
9986  & answer_shape(1), &
9987 
9988  & answer_shape(2), &
9989 
9990  & answer_shape(3), &
9991 
9992  & answer_shape(4), &
9993 
9994  & answer_shape(5) ) &
9995  & )
9996 
9997  allocate( answer_negative( &
9998  & answer_shape(1), &
9999 
10000  & answer_shape(2), &
10001 
10002  & answer_shape(3), &
10003 
10004  & answer_shape(4), &
10005 
10006  & answer_shape(5) ) &
10007  & )
10008 
10009  allocate( check_negative( &
10010  & answer_shape(1), &
10011 
10012  & answer_shape(2), &
10013 
10014  & answer_shape(3), &
10015 
10016  & answer_shape(4), &
10017 
10018  & answer_shape(5) ) &
10019  & )
10020 
10021  allocate( both_negative( &
10022  & answer_shape(1), &
10023 
10024  & answer_shape(2), &
10025 
10026  & answer_shape(3), &
10027 
10028  & answer_shape(4), &
10029 
10030  & answer_shape(5) ) &
10031  & )
10032 
10033  answer_negative = answer < 0
10034  check_negative = check < 0
10035  both_negative = answer_negative .and. check_negative
10036  if (.not. negative_support_on) both_negative = .false.
10037 
10038  judge = answer < check
10039  where (both_negative) judge = .not. judge
10040 
10041  judge_rev = .not. judge
10042  err_flag = any(judge_rev)
10043  mask_array = 1
10044  pos = maxloc(mask_array, judge_rev)
10045 
10046  if (err_flag) then
10047 
10048  wrong = check( &
10049  & pos(1), &
10050 
10051  & pos(2), &
10052 
10053  & pos(3), &
10054 
10055  & pos(4), &
10056 
10057  & pos(5) )
10058 
10059  right = answer( &
10060  & pos(1), &
10061 
10062  & pos(2), &
10063 
10064  & pos(3), &
10065 
10066  & pos(4), &
10067 
10068  & pos(5) )
10069 
10070  write(unit=pos_array(1), fmt="(i20)") pos(1)
10071 
10072  write(unit=pos_array(2), fmt="(i20)") pos(2)
10073 
10074  write(unit=pos_array(3), fmt="(i20)") pos(3)
10075 
10076  write(unit=pos_array(4), fmt="(i20)") pos(4)
10077 
10078  write(unit=pos_array(5), fmt="(i20)") pos(5)
10079 
10080 
10081  pos_str = '(' // &
10082  & trim(adjustl(pos_array(1))) // ',' // &
10083 
10084  & trim(adjustl(pos_array(2))) // ',' // &
10085 
10086  & trim(adjustl(pos_array(3))) // ',' // &
10087 
10088  & trim(adjustl(pos_array(4))) // ',' // &
10089 
10090  & trim(adjustl(pos_array(5))) // ')'
10091 
10092  if ( both_negative( &
10093  & pos(1), &
10094 
10095  & pos(2), &
10096 
10097  & pos(3), &
10098 
10099  & pos(4), &
10100 
10101  & pos(5) ) ) then
10102 
10103  abs_mes = 'ABSOLUTE value of'
10104  else
10105  abs_mes = ''
10106 
10107  end if
10108 
10109  end if
10110  deallocate(mask_array, judge, judge_rev)
10111  deallocate(answer_negative, check_negative, both_negative)
10112 
10113 
10114 
10115 
10116  if (err_flag) then
10117  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10118  write(*,*) ''
10119  write(*,*) ' ' // trim(abs_mes) // &
10120  & ' check' // trim(pos_str) // ' = ', wrong
10121  write(*,*) ' is NOT GREATER THAN'
10122  write(*,*) ' ' // trim(abs_mes) // &
10123  & ' answer' // trim(pos_str) // ' = ', right
10124 
10125  call abortprogram('')
10126  else
10127  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10128  end if
10129 
10130 
10131  end subroutine dctestassertgreaterthanint5
10132 
10133 
10134  subroutine dctestassertgreaterthanint6( &
10135  & message, answer, check, negative_support)
10136  use sysdep, only: abortprogram
10137  use dc_types, only: string, token
10138  implicit none
10139  character(*), intent(in):: message
10140  integer, intent(in):: answer(:,:,:,:,:,:)
10141  integer, intent(in):: check(:,:,:,:,:,:)
10142  logical, intent(in), optional:: negative_support
10143  logical:: err_flag
10144  logical:: negative_support_on
10145  character(STRING):: pos_str
10146  character(TOKEN):: abs_mes
10147  integer:: wrong, right
10148 
10149  integer:: answer_shape(6), check_shape(6), pos(6)
10150  logical:: consist_shape(6)
10151  character(TOKEN):: pos_array(6)
10152  integer, allocatable:: mask_array(:,:,:,:,:,:)
10153  logical, allocatable:: judge(:,:,:,:,:,:)
10154  logical, allocatable:: judge_rev(:,:,:,:,:,:)
10155  logical, allocatable:: answer_negative(:,:,:,:,:,:)
10156  logical, allocatable:: check_negative(:,:,:,:,:,:)
10157  logical, allocatable:: both_negative(:,:,:,:,:,:)
10158 
10159 
10160  continue
10161  if (present(negative_support)) then
10162  negative_support_on = negative_support
10163  else
10164  negative_support_on = .true.
10165  end if
10166 
10167  err_flag = .false.
10168 
10169 
10170  answer_shape = shape(answer)
10171  check_shape = shape(check)
10172 
10173  consist_shape = answer_shape == check_shape
10174 
10175  if (.not. all(consist_shape)) then
10176  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10177  write(*,*) ''
10178  write(*,*) ' shape of check is (', check_shape, ')'
10179  write(*,*) ' is INCORRECT'
10180  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10181 
10182  call abortprogram('')
10183  end if
10184 
10185 
10186  allocate( mask_array( &
10187  & answer_shape(1), &
10188 
10189  & answer_shape(2), &
10190 
10191  & answer_shape(3), &
10192 
10193  & answer_shape(4), &
10194 
10195  & answer_shape(5), &
10196 
10197  & answer_shape(6) ) &
10198  & )
10199 
10200  allocate( judge( &
10201  & answer_shape(1), &
10202 
10203  & answer_shape(2), &
10204 
10205  & answer_shape(3), &
10206 
10207  & answer_shape(4), &
10208 
10209  & answer_shape(5), &
10210 
10211  & answer_shape(6) ) &
10212  & )
10213 
10214  allocate( judge_rev( &
10215  & answer_shape(1), &
10216 
10217  & answer_shape(2), &
10218 
10219  & answer_shape(3), &
10220 
10221  & answer_shape(4), &
10222 
10223  & answer_shape(5), &
10224 
10225  & answer_shape(6) ) &
10226  & )
10227 
10228  allocate( answer_negative( &
10229  & answer_shape(1), &
10230 
10231  & answer_shape(2), &
10232 
10233  & answer_shape(3), &
10234 
10235  & answer_shape(4), &
10236 
10237  & answer_shape(5), &
10238 
10239  & answer_shape(6) ) &
10240  & )
10241 
10242  allocate( check_negative( &
10243  & answer_shape(1), &
10244 
10245  & answer_shape(2), &
10246 
10247  & answer_shape(3), &
10248 
10249  & answer_shape(4), &
10250 
10251  & answer_shape(5), &
10252 
10253  & answer_shape(6) ) &
10254  & )
10255 
10256  allocate( both_negative( &
10257  & answer_shape(1), &
10258 
10259  & answer_shape(2), &
10260 
10261  & answer_shape(3), &
10262 
10263  & answer_shape(4), &
10264 
10265  & answer_shape(5), &
10266 
10267  & answer_shape(6) ) &
10268  & )
10269 
10270  answer_negative = answer < 0
10271  check_negative = check < 0
10272  both_negative = answer_negative .and. check_negative
10273  if (.not. negative_support_on) both_negative = .false.
10274 
10275  judge = answer < check
10276  where (both_negative) judge = .not. judge
10277 
10278  judge_rev = .not. judge
10279  err_flag = any(judge_rev)
10280  mask_array = 1
10281  pos = maxloc(mask_array, judge_rev)
10282 
10283  if (err_flag) then
10284 
10285  wrong = check( &
10286  & pos(1), &
10287 
10288  & pos(2), &
10289 
10290  & pos(3), &
10291 
10292  & pos(4), &
10293 
10294  & pos(5), &
10295 
10296  & pos(6) )
10297 
10298  right = answer( &
10299  & pos(1), &
10300 
10301  & pos(2), &
10302 
10303  & pos(3), &
10304 
10305  & pos(4), &
10306 
10307  & pos(5), &
10308 
10309  & pos(6) )
10310 
10311  write(unit=pos_array(1), fmt="(i20)") pos(1)
10312 
10313  write(unit=pos_array(2), fmt="(i20)") pos(2)
10314 
10315  write(unit=pos_array(3), fmt="(i20)") pos(3)
10316 
10317  write(unit=pos_array(4), fmt="(i20)") pos(4)
10318 
10319  write(unit=pos_array(5), fmt="(i20)") pos(5)
10320 
10321  write(unit=pos_array(6), fmt="(i20)") pos(6)
10322 
10323 
10324  pos_str = '(' // &
10325  & trim(adjustl(pos_array(1))) // ',' // &
10326 
10327  & trim(adjustl(pos_array(2))) // ',' // &
10328 
10329  & trim(adjustl(pos_array(3))) // ',' // &
10330 
10331  & trim(adjustl(pos_array(4))) // ',' // &
10332 
10333  & trim(adjustl(pos_array(5))) // ',' // &
10334 
10335  & trim(adjustl(pos_array(6))) // ')'
10336 
10337  if ( both_negative( &
10338  & pos(1), &
10339 
10340  & pos(2), &
10341 
10342  & pos(3), &
10343 
10344  & pos(4), &
10345 
10346  & pos(5), &
10347 
10348  & pos(6) ) ) then
10349 
10350  abs_mes = 'ABSOLUTE value of'
10351  else
10352  abs_mes = ''
10353 
10354  end if
10355 
10356  end if
10357  deallocate(mask_array, judge, judge_rev)
10358  deallocate(answer_negative, check_negative, both_negative)
10359 
10360 
10361 
10362 
10363  if (err_flag) then
10364  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10365  write(*,*) ''
10366  write(*,*) ' ' // trim(abs_mes) // &
10367  & ' check' // trim(pos_str) // ' = ', wrong
10368  write(*,*) ' is NOT GREATER THAN'
10369  write(*,*) ' ' // trim(abs_mes) // &
10370  & ' answer' // trim(pos_str) // ' = ', right
10371 
10372  call abortprogram('')
10373  else
10374  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10375  end if
10376 
10377 
10378  end subroutine dctestassertgreaterthanint6
10379 
10380 
10381  subroutine dctestassertgreaterthanint7( &
10382  & message, answer, check, negative_support)
10383  use sysdep, only: abortprogram
10384  use dc_types, only: string, token
10385  implicit none
10386  character(*), intent(in):: message
10387  integer, intent(in):: answer(:,:,:,:,:,:,:)
10388  integer, intent(in):: check(:,:,:,:,:,:,:)
10389  logical, intent(in), optional:: negative_support
10390  logical:: err_flag
10391  logical:: negative_support_on
10392  character(STRING):: pos_str
10393  character(TOKEN):: abs_mes
10394  integer:: wrong, right
10395 
10396  integer:: answer_shape(7), check_shape(7), pos(7)
10397  logical:: consist_shape(7)
10398  character(TOKEN):: pos_array(7)
10399  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
10400  logical, allocatable:: judge(:,:,:,:,:,:,:)
10401  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
10402  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
10403  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
10404  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
10405 
10406 
10407  continue
10408  if (present(negative_support)) then
10409  negative_support_on = negative_support
10410  else
10411  negative_support_on = .true.
10412  end if
10413 
10414  err_flag = .false.
10415 
10416 
10417  answer_shape = shape(answer)
10418  check_shape = shape(check)
10419 
10420  consist_shape = answer_shape == check_shape
10421 
10422  if (.not. all(consist_shape)) then
10423  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10424  write(*,*) ''
10425  write(*,*) ' shape of check is (', check_shape, ')'
10426  write(*,*) ' is INCORRECT'
10427  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10428 
10429  call abortprogram('')
10430  end if
10431 
10432 
10433  allocate( mask_array( &
10434  & answer_shape(1), &
10435 
10436  & answer_shape(2), &
10437 
10438  & answer_shape(3), &
10439 
10440  & answer_shape(4), &
10441 
10442  & answer_shape(5), &
10443 
10444  & answer_shape(6), &
10445 
10446  & answer_shape(7) ) &
10447  & )
10448 
10449  allocate( judge( &
10450  & answer_shape(1), &
10451 
10452  & answer_shape(2), &
10453 
10454  & answer_shape(3), &
10455 
10456  & answer_shape(4), &
10457 
10458  & answer_shape(5), &
10459 
10460  & answer_shape(6), &
10461 
10462  & answer_shape(7) ) &
10463  & )
10464 
10465  allocate( judge_rev( &
10466  & answer_shape(1), &
10467 
10468  & answer_shape(2), &
10469 
10470  & answer_shape(3), &
10471 
10472  & answer_shape(4), &
10473 
10474  & answer_shape(5), &
10475 
10476  & answer_shape(6), &
10477 
10478  & answer_shape(7) ) &
10479  & )
10480 
10481  allocate( answer_negative( &
10482  & answer_shape(1), &
10483 
10484  & answer_shape(2), &
10485 
10486  & answer_shape(3), &
10487 
10488  & answer_shape(4), &
10489 
10490  & answer_shape(5), &
10491 
10492  & answer_shape(6), &
10493 
10494  & answer_shape(7) ) &
10495  & )
10496 
10497  allocate( check_negative( &
10498  & answer_shape(1), &
10499 
10500  & answer_shape(2), &
10501 
10502  & answer_shape(3), &
10503 
10504  & answer_shape(4), &
10505 
10506  & answer_shape(5), &
10507 
10508  & answer_shape(6), &
10509 
10510  & answer_shape(7) ) &
10511  & )
10512 
10513  allocate( both_negative( &
10514  & answer_shape(1), &
10515 
10516  & answer_shape(2), &
10517 
10518  & answer_shape(3), &
10519 
10520  & answer_shape(4), &
10521 
10522  & answer_shape(5), &
10523 
10524  & answer_shape(6), &
10525 
10526  & answer_shape(7) ) &
10527  & )
10528 
10529  answer_negative = answer < 0
10530  check_negative = check < 0
10531  both_negative = answer_negative .and. check_negative
10532  if (.not. negative_support_on) both_negative = .false.
10533 
10534  judge = answer < check
10535  where (both_negative) judge = .not. judge
10536 
10537  judge_rev = .not. judge
10538  err_flag = any(judge_rev)
10539  mask_array = 1
10540  pos = maxloc(mask_array, judge_rev)
10541 
10542  if (err_flag) then
10543 
10544  wrong = check( &
10545  & pos(1), &
10546 
10547  & pos(2), &
10548 
10549  & pos(3), &
10550 
10551  & pos(4), &
10552 
10553  & pos(5), &
10554 
10555  & pos(6), &
10556 
10557  & pos(7) )
10558 
10559  right = answer( &
10560  & pos(1), &
10561 
10562  & pos(2), &
10563 
10564  & pos(3), &
10565 
10566  & pos(4), &
10567 
10568  & pos(5), &
10569 
10570  & pos(6), &
10571 
10572  & pos(7) )
10573 
10574  write(unit=pos_array(1), fmt="(i20)") pos(1)
10575 
10576  write(unit=pos_array(2), fmt="(i20)") pos(2)
10577 
10578  write(unit=pos_array(3), fmt="(i20)") pos(3)
10579 
10580  write(unit=pos_array(4), fmt="(i20)") pos(4)
10581 
10582  write(unit=pos_array(5), fmt="(i20)") pos(5)
10583 
10584  write(unit=pos_array(6), fmt="(i20)") pos(6)
10585 
10586  write(unit=pos_array(7), fmt="(i20)") pos(7)
10587 
10588 
10589  pos_str = '(' // &
10590  & trim(adjustl(pos_array(1))) // ',' // &
10591 
10592  & trim(adjustl(pos_array(2))) // ',' // &
10593 
10594  & trim(adjustl(pos_array(3))) // ',' // &
10595 
10596  & trim(adjustl(pos_array(4))) // ',' // &
10597 
10598  & trim(adjustl(pos_array(5))) // ',' // &
10599 
10600  & trim(adjustl(pos_array(6))) // ',' // &
10601 
10602  & trim(adjustl(pos_array(7))) // ')'
10603 
10604  if ( both_negative( &
10605  & pos(1), &
10606 
10607  & pos(2), &
10608 
10609  & pos(3), &
10610 
10611  & pos(4), &
10612 
10613  & pos(5), &
10614 
10615  & pos(6), &
10616 
10617  & pos(7) ) ) then
10618 
10619  abs_mes = 'ABSOLUTE value of'
10620  else
10621  abs_mes = ''
10622 
10623  end if
10624 
10625  end if
10626  deallocate(mask_array, judge, judge_rev)
10627  deallocate(answer_negative, check_negative, both_negative)
10628 
10629 
10630 
10631 
10632  if (err_flag) then
10633  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10634  write(*,*) ''
10635  write(*,*) ' ' // trim(abs_mes) // &
10636  & ' check' // trim(pos_str) // ' = ', wrong
10637  write(*,*) ' is NOT GREATER THAN'
10638  write(*,*) ' ' // trim(abs_mes) // &
10639  & ' answer' // trim(pos_str) // ' = ', right
10640 
10641  call abortprogram('')
10642  else
10643  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10644  end if
10645 
10646 
10647  end subroutine dctestassertgreaterthanint7
10648 
10649 
10650  subroutine dctestassertgreaterthanreal0( &
10651  & message, answer, check, negative_support)
10652  use sysdep, only: abortprogram
10653  use dc_types, only: string, token
10654  implicit none
10655  character(*), intent(in):: message
10656  real, intent(in):: answer
10657  real, intent(in):: check
10658  logical, intent(in), optional:: negative_support
10659  logical:: err_flag
10660  logical:: negative_support_on
10661  character(STRING):: pos_str
10662  character(TOKEN):: abs_mes
10663  real:: wrong, right
10664 
10665 
10666 
10667  continue
10668  if (present(negative_support)) then
10669  negative_support_on = negative_support
10670  else
10671  negative_support_on = .true.
10672  end if
10673 
10674  err_flag = .false.
10675 
10676 
10677  err_flag = .not. answer < check
10678  abs_mes = ''
10679 
10680  if ( answer < 0.0 &
10681  & .and. check < 0.0 &
10682  & .and. negative_support_on ) then
10683 
10684  err_flag = .not. err_flag
10685  abs_mes = 'ABSOLUTE value of'
10686  end if
10687 
10688  wrong = check
10689  right = answer
10690  pos_str = ''
10691 
10692 
10693 
10694 
10695  if (err_flag) then
10696  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10697  write(*,*) ''
10698  write(*,*) ' ' // trim(abs_mes) // &
10699  & ' check' // trim(pos_str) // ' = ', wrong
10700  write(*,*) ' is NOT GREATER THAN'
10701  write(*,*) ' ' // trim(abs_mes) // &
10702  & ' answer' // trim(pos_str) // ' = ', right
10703 
10704  call abortprogram('')
10705  else
10706  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10707  end if
10708 
10709 
10710  end subroutine dctestassertgreaterthanreal0
10711 
10712 
10713  subroutine dctestassertgreaterthanreal1( &
10714  & message, answer, check, negative_support)
10715  use sysdep, only: abortprogram
10716  use dc_types, only: string, token
10717  implicit none
10718  character(*), intent(in):: message
10719  real, intent(in):: answer(:)
10720  real, intent(in):: check(:)
10721  logical, intent(in), optional:: negative_support
10722  logical:: err_flag
10723  logical:: negative_support_on
10724  character(STRING):: pos_str
10725  character(TOKEN):: abs_mes
10726  real:: wrong, right
10727 
10728  integer:: answer_shape(1), check_shape(1), pos(1)
10729  logical:: consist_shape(1)
10730  character(TOKEN):: pos_array(1)
10731  integer, allocatable:: mask_array(:)
10732  logical, allocatable:: judge(:)
10733  logical, allocatable:: judge_rev(:)
10734  logical, allocatable:: answer_negative(:)
10735  logical, allocatable:: check_negative(:)
10736  logical, allocatable:: both_negative(:)
10737 
10738 
10739  continue
10740  if (present(negative_support)) then
10741  negative_support_on = negative_support
10742  else
10743  negative_support_on = .true.
10744  end if
10745 
10746  err_flag = .false.
10747 
10748 
10749  answer_shape = shape(answer)
10750  check_shape = shape(check)
10751 
10752  consist_shape = answer_shape == check_shape
10753 
10754  if (.not. all(consist_shape)) then
10755  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10756  write(*,*) ''
10757  write(*,*) ' shape of check is (', check_shape, ')'
10758  write(*,*) ' is INCORRECT'
10759  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10760 
10761  call abortprogram('')
10762  end if
10763 
10764 
10765  allocate( mask_array( &
10766 
10767  & answer_shape(1) ) &
10768  & )
10769 
10770  allocate( judge( &
10771 
10772  & answer_shape(1) ) &
10773  & )
10774 
10775  allocate( judge_rev( &
10776 
10777  & answer_shape(1) ) &
10778  & )
10779 
10780  allocate( answer_negative( &
10781 
10782  & answer_shape(1) ) &
10783  & )
10784 
10785  allocate( check_negative( &
10786 
10787  & answer_shape(1) ) &
10788  & )
10789 
10790  allocate( both_negative( &
10791 
10792  & answer_shape(1) ) &
10793  & )
10794 
10795  answer_negative = answer < 0.0
10796  check_negative = check < 0.0
10797  both_negative = answer_negative .and. check_negative
10798  if (.not. negative_support_on) both_negative = .false.
10799 
10800  judge = answer < check
10801  where (both_negative) judge = .not. judge
10802 
10803  judge_rev = .not. judge
10804  err_flag = any(judge_rev)
10805  mask_array = 1
10806  pos = maxloc(mask_array, judge_rev)
10807 
10808  if (err_flag) then
10809 
10810  wrong = check( &
10811 
10812  & pos(1) )
10813 
10814  right = answer( &
10815 
10816  & pos(1) )
10817 
10818  write(unit=pos_array(1), fmt="(i20)") pos(1)
10819 
10820 
10821  pos_str = '(' // &
10822 
10823  & trim(adjustl(pos_array(1))) // ')'
10824 
10825  if ( both_negative( &
10826 
10827  & pos(1) ) ) then
10828 
10829  abs_mes = 'ABSOLUTE value of'
10830  else
10831  abs_mes = ''
10832 
10833  end if
10834 
10835  end if
10836  deallocate(mask_array, judge, judge_rev)
10837  deallocate(answer_negative, check_negative, both_negative)
10838 
10839 
10840 
10841 
10842  if (err_flag) then
10843  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10844  write(*,*) ''
10845  write(*,*) ' ' // trim(abs_mes) // &
10846  & ' check' // trim(pos_str) // ' = ', wrong
10847  write(*,*) ' is NOT GREATER THAN'
10848  write(*,*) ' ' // trim(abs_mes) // &
10849  & ' answer' // trim(pos_str) // ' = ', right
10850 
10851  call abortprogram('')
10852  else
10853  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10854  end if
10855 
10856 
10857  end subroutine dctestassertgreaterthanreal1
10858 
10859 
10860  subroutine dctestassertgreaterthanreal2( &
10861  & message, answer, check, negative_support)
10862  use sysdep, only: abortprogram
10863  use dc_types, only: string, token
10864  implicit none
10865  character(*), intent(in):: message
10866  real, intent(in):: answer(:,:)
10867  real, intent(in):: check(:,:)
10868  logical, intent(in), optional:: negative_support
10869  logical:: err_flag
10870  logical:: negative_support_on
10871  character(STRING):: pos_str
10872  character(TOKEN):: abs_mes
10873  real:: wrong, right
10874 
10875  integer:: answer_shape(2), check_shape(2), pos(2)
10876  logical:: consist_shape(2)
10877  character(TOKEN):: pos_array(2)
10878  integer, allocatable:: mask_array(:,:)
10879  logical, allocatable:: judge(:,:)
10880  logical, allocatable:: judge_rev(:,:)
10881  logical, allocatable:: answer_negative(:,:)
10882  logical, allocatable:: check_negative(:,:)
10883  logical, allocatable:: both_negative(:,:)
10884 
10885 
10886  continue
10887  if (present(negative_support)) then
10888  negative_support_on = negative_support
10889  else
10890  negative_support_on = .true.
10891  end if
10892 
10893  err_flag = .false.
10894 
10895 
10896  answer_shape = shape(answer)
10897  check_shape = shape(check)
10898 
10899  consist_shape = answer_shape == check_shape
10900 
10901  if (.not. all(consist_shape)) then
10902  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10903  write(*,*) ''
10904  write(*,*) ' shape of check is (', check_shape, ')'
10905  write(*,*) ' is INCORRECT'
10906  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10907 
10908  call abortprogram('')
10909  end if
10910 
10911 
10912  allocate( mask_array( &
10913  & answer_shape(1), &
10914 
10915  & answer_shape(2) ) &
10916  & )
10917 
10918  allocate( judge( &
10919  & answer_shape(1), &
10920 
10921  & answer_shape(2) ) &
10922  & )
10923 
10924  allocate( judge_rev( &
10925  & answer_shape(1), &
10926 
10927  & answer_shape(2) ) &
10928  & )
10929 
10930  allocate( answer_negative( &
10931  & answer_shape(1), &
10932 
10933  & answer_shape(2) ) &
10934  & )
10935 
10936  allocate( check_negative( &
10937  & answer_shape(1), &
10938 
10939  & answer_shape(2) ) &
10940  & )
10941 
10942  allocate( both_negative( &
10943  & answer_shape(1), &
10944 
10945  & answer_shape(2) ) &
10946  & )
10947 
10948  answer_negative = answer < 0.0
10949  check_negative = check < 0.0
10950  both_negative = answer_negative .and. check_negative
10951  if (.not. negative_support_on) both_negative = .false.
10952 
10953  judge = answer < check
10954  where (both_negative) judge = .not. judge
10955 
10956  judge_rev = .not. judge
10957  err_flag = any(judge_rev)
10958  mask_array = 1
10959  pos = maxloc(mask_array, judge_rev)
10960 
10961  if (err_flag) then
10962 
10963  wrong = check( &
10964  & pos(1), &
10965 
10966  & pos(2) )
10967 
10968  right = answer( &
10969  & pos(1), &
10970 
10971  & pos(2) )
10972 
10973  write(unit=pos_array(1), fmt="(i20)") pos(1)
10974 
10975  write(unit=pos_array(2), fmt="(i20)") pos(2)
10976 
10977 
10978  pos_str = '(' // &
10979  & trim(adjustl(pos_array(1))) // ',' // &
10980 
10981  & trim(adjustl(pos_array(2))) // ')'
10982 
10983  if ( both_negative( &
10984  & pos(1), &
10985 
10986  & pos(2) ) ) then
10987 
10988  abs_mes = 'ABSOLUTE value of'
10989  else
10990  abs_mes = ''
10991 
10992  end if
10993 
10994  end if
10995  deallocate(mask_array, judge, judge_rev)
10996  deallocate(answer_negative, check_negative, both_negative)
10997 
10998 
10999 
11000 
11001  if (err_flag) then
11002  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11003  write(*,*) ''
11004  write(*,*) ' ' // trim(abs_mes) // &
11005  & ' check' // trim(pos_str) // ' = ', wrong
11006  write(*,*) ' is NOT GREATER THAN'
11007  write(*,*) ' ' // trim(abs_mes) // &
11008  & ' answer' // trim(pos_str) // ' = ', right
11009 
11010  call abortprogram('')
11011  else
11012  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11013  end if
11014 
11015 
11016  end subroutine dctestassertgreaterthanreal2
11017 
11018 
11019  subroutine dctestassertgreaterthanreal3( &
11020  & message, answer, check, negative_support)
11021  use sysdep, only: abortprogram
11022  use dc_types, only: string, token
11023  implicit none
11024  character(*), intent(in):: message
11025  real, intent(in):: answer(:,:,:)
11026  real, intent(in):: check(:,:,:)
11027  logical, intent(in), optional:: negative_support
11028  logical:: err_flag
11029  logical:: negative_support_on
11030  character(STRING):: pos_str
11031  character(TOKEN):: abs_mes
11032  real:: wrong, right
11033 
11034  integer:: answer_shape(3), check_shape(3), pos(3)
11035  logical:: consist_shape(3)
11036  character(TOKEN):: pos_array(3)
11037  integer, allocatable:: mask_array(:,:,:)
11038  logical, allocatable:: judge(:,:,:)
11039  logical, allocatable:: judge_rev(:,:,:)
11040  logical, allocatable:: answer_negative(:,:,:)
11041  logical, allocatable:: check_negative(:,:,:)
11042  logical, allocatable:: both_negative(:,:,:)
11043 
11044 
11045  continue
11046  if (present(negative_support)) then
11047  negative_support_on = negative_support
11048  else
11049  negative_support_on = .true.
11050  end if
11051 
11052  err_flag = .false.
11053 
11054 
11055  answer_shape = shape(answer)
11056  check_shape = shape(check)
11057 
11058  consist_shape = answer_shape == check_shape
11059 
11060  if (.not. all(consist_shape)) then
11061  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11062  write(*,*) ''
11063  write(*,*) ' shape of check is (', check_shape, ')'
11064  write(*,*) ' is INCORRECT'
11065  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11066 
11067  call abortprogram('')
11068  end if
11069 
11070 
11071  allocate( mask_array( &
11072  & answer_shape(1), &
11073 
11074  & answer_shape(2), &
11075 
11076  & answer_shape(3) ) &
11077  & )
11078 
11079  allocate( judge( &
11080  & answer_shape(1), &
11081 
11082  & answer_shape(2), &
11083 
11084  & answer_shape(3) ) &
11085  & )
11086 
11087  allocate( judge_rev( &
11088  & answer_shape(1), &
11089 
11090  & answer_shape(2), &
11091 
11092  & answer_shape(3) ) &
11093  & )
11094 
11095  allocate( answer_negative( &
11096  & answer_shape(1), &
11097 
11098  & answer_shape(2), &
11099 
11100  & answer_shape(3) ) &
11101  & )
11102 
11103  allocate( check_negative( &
11104  & answer_shape(1), &
11105 
11106  & answer_shape(2), &
11107 
11108  & answer_shape(3) ) &
11109  & )
11110 
11111  allocate( both_negative( &
11112  & answer_shape(1), &
11113 
11114  & answer_shape(2), &
11115 
11116  & answer_shape(3) ) &
11117  & )
11118 
11119  answer_negative = answer < 0.0
11120  check_negative = check < 0.0
11121  both_negative = answer_negative .and. check_negative
11122  if (.not. negative_support_on) both_negative = .false.
11123 
11124  judge = answer < check
11125  where (both_negative) judge = .not. judge
11126 
11127  judge_rev = .not. judge
11128  err_flag = any(judge_rev)
11129  mask_array = 1
11130  pos = maxloc(mask_array, judge_rev)
11131 
11132  if (err_flag) then
11133 
11134  wrong = check( &
11135  & pos(1), &
11136 
11137  & pos(2), &
11138 
11139  & pos(3) )
11140 
11141  right = answer( &
11142  & pos(1), &
11143 
11144  & pos(2), &
11145 
11146  & pos(3) )
11147 
11148  write(unit=pos_array(1), fmt="(i20)") pos(1)
11149 
11150  write(unit=pos_array(2), fmt="(i20)") pos(2)
11151 
11152  write(unit=pos_array(3), fmt="(i20)") pos(3)
11153 
11154 
11155  pos_str = '(' // &
11156  & trim(adjustl(pos_array(1))) // ',' // &
11157 
11158  & trim(adjustl(pos_array(2))) // ',' // &
11159 
11160  & trim(adjustl(pos_array(3))) // ')'
11161 
11162  if ( both_negative( &
11163  & pos(1), &
11164 
11165  & pos(2), &
11166 
11167  & pos(3) ) ) then
11168 
11169  abs_mes = 'ABSOLUTE value of'
11170  else
11171  abs_mes = ''
11172 
11173  end if
11174 
11175  end if
11176  deallocate(mask_array, judge, judge_rev)
11177  deallocate(answer_negative, check_negative, both_negative)
11178 
11179 
11180 
11181 
11182  if (err_flag) then
11183  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11184  write(*,*) ''
11185  write(*,*) ' ' // trim(abs_mes) // &
11186  & ' check' // trim(pos_str) // ' = ', wrong
11187  write(*,*) ' is NOT GREATER THAN'
11188  write(*,*) ' ' // trim(abs_mes) // &
11189  & ' answer' // trim(pos_str) // ' = ', right
11190 
11191  call abortprogram('')
11192  else
11193  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11194  end if
11195 
11196 
11197  end subroutine dctestassertgreaterthanreal3
11198 
11199 
11200  subroutine dctestassertgreaterthanreal4( &
11201  & message, answer, check, negative_support)
11202  use sysdep, only: abortprogram
11203  use dc_types, only: string, token
11204  implicit none
11205  character(*), intent(in):: message
11206  real, intent(in):: answer(:,:,:,:)
11207  real, intent(in):: check(:,:,:,:)
11208  logical, intent(in), optional:: negative_support
11209  logical:: err_flag
11210  logical:: negative_support_on
11211  character(STRING):: pos_str
11212  character(TOKEN):: abs_mes
11213  real:: wrong, right
11214 
11215  integer:: answer_shape(4), check_shape(4), pos(4)
11216  logical:: consist_shape(4)
11217  character(TOKEN):: pos_array(4)
11218  integer, allocatable:: mask_array(:,:,:,:)
11219  logical, allocatable:: judge(:,:,:,:)
11220  logical, allocatable:: judge_rev(:,:,:,:)
11221  logical, allocatable:: answer_negative(:,:,:,:)
11222  logical, allocatable:: check_negative(:,:,:,:)
11223  logical, allocatable:: both_negative(:,:,:,:)
11224 
11225 
11226  continue
11227  if (present(negative_support)) then
11228  negative_support_on = negative_support
11229  else
11230  negative_support_on = .true.
11231  end if
11232 
11233  err_flag = .false.
11234 
11235 
11236  answer_shape = shape(answer)
11237  check_shape = shape(check)
11238 
11239  consist_shape = answer_shape == check_shape
11240 
11241  if (.not. all(consist_shape)) then
11242  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11243  write(*,*) ''
11244  write(*,*) ' shape of check is (', check_shape, ')'
11245  write(*,*) ' is INCORRECT'
11246  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11247 
11248  call abortprogram('')
11249  end if
11250 
11251 
11252  allocate( mask_array( &
11253  & answer_shape(1), &
11254 
11255  & answer_shape(2), &
11256 
11257  & answer_shape(3), &
11258 
11259  & answer_shape(4) ) &
11260  & )
11261 
11262  allocate( judge( &
11263  & answer_shape(1), &
11264 
11265  & answer_shape(2), &
11266 
11267  & answer_shape(3), &
11268 
11269  & answer_shape(4) ) &
11270  & )
11271 
11272  allocate( judge_rev( &
11273  & answer_shape(1), &
11274 
11275  & answer_shape(2), &
11276 
11277  & answer_shape(3), &
11278 
11279  & answer_shape(4) ) &
11280  & )
11281 
11282  allocate( answer_negative( &
11283  & answer_shape(1), &
11284 
11285  & answer_shape(2), &
11286 
11287  & answer_shape(3), &
11288 
11289  & answer_shape(4) ) &
11290  & )
11291 
11292  allocate( check_negative( &
11293  & answer_shape(1), &
11294 
11295  & answer_shape(2), &
11296 
11297  & answer_shape(3), &
11298 
11299  & answer_shape(4) ) &
11300  & )
11301 
11302  allocate( both_negative( &
11303  & answer_shape(1), &
11304 
11305  & answer_shape(2), &
11306 
11307  & answer_shape(3), &
11308 
11309  & answer_shape(4) ) &
11310  & )
11311 
11312  answer_negative = answer < 0.0
11313  check_negative = check < 0.0
11314  both_negative = answer_negative .and. check_negative
11315  if (.not. negative_support_on) both_negative = .false.
11316 
11317  judge = answer < check
11318  where (both_negative) judge = .not. judge
11319 
11320  judge_rev = .not. judge
11321  err_flag = any(judge_rev)
11322  mask_array = 1
11323  pos = maxloc(mask_array, judge_rev)
11324 
11325  if (err_flag) then
11326 
11327  wrong = check( &
11328  & pos(1), &
11329 
11330  & pos(2), &
11331 
11332  & pos(3), &
11333 
11334  & pos(4) )
11335 
11336  right = answer( &
11337  & pos(1), &
11338 
11339  & pos(2), &
11340 
11341  & pos(3), &
11342 
11343  & pos(4) )
11344 
11345  write(unit=pos_array(1), fmt="(i20)") pos(1)
11346 
11347  write(unit=pos_array(2), fmt="(i20)") pos(2)
11348 
11349  write(unit=pos_array(3), fmt="(i20)") pos(3)
11350 
11351  write(unit=pos_array(4), fmt="(i20)") pos(4)
11352 
11353 
11354  pos_str = '(' // &
11355  & trim(adjustl(pos_array(1))) // ',' // &
11356 
11357  & trim(adjustl(pos_array(2))) // ',' // &
11358 
11359  & trim(adjustl(pos_array(3))) // ',' // &
11360 
11361  & trim(adjustl(pos_array(4))) // ')'
11362 
11363  if ( both_negative( &
11364  & pos(1), &
11365 
11366  & pos(2), &
11367 
11368  & pos(3), &
11369 
11370  & pos(4) ) ) then
11371 
11372  abs_mes = 'ABSOLUTE value of'
11373  else
11374  abs_mes = ''
11375 
11376  end if
11377 
11378  end if
11379  deallocate(mask_array, judge, judge_rev)
11380  deallocate(answer_negative, check_negative, both_negative)
11381 
11382 
11383 
11384 
11385  if (err_flag) then
11386  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11387  write(*,*) ''
11388  write(*,*) ' ' // trim(abs_mes) // &
11389  & ' check' // trim(pos_str) // ' = ', wrong
11390  write(*,*) ' is NOT GREATER THAN'
11391  write(*,*) ' ' // trim(abs_mes) // &
11392  & ' answer' // trim(pos_str) // ' = ', right
11393 
11394  call abortprogram('')
11395  else
11396  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11397  end if
11398 
11399 
11400  end subroutine dctestassertgreaterthanreal4
11401 
11402 
11403  subroutine dctestassertgreaterthanreal5( &
11404  & message, answer, check, negative_support)
11405  use sysdep, only: abortprogram
11406  use dc_types, only: string, token
11407  implicit none
11408  character(*), intent(in):: message
11409  real, intent(in):: answer(:,:,:,:,:)
11410  real, intent(in):: check(:,:,:,:,:)
11411  logical, intent(in), optional:: negative_support
11412  logical:: err_flag
11413  logical:: negative_support_on
11414  character(STRING):: pos_str
11415  character(TOKEN):: abs_mes
11416  real:: wrong, right
11417 
11418  integer:: answer_shape(5), check_shape(5), pos(5)
11419  logical:: consist_shape(5)
11420  character(TOKEN):: pos_array(5)
11421  integer, allocatable:: mask_array(:,:,:,:,:)
11422  logical, allocatable:: judge(:,:,:,:,:)
11423  logical, allocatable:: judge_rev(:,:,:,:,:)
11424  logical, allocatable:: answer_negative(:,:,:,:,:)
11425  logical, allocatable:: check_negative(:,:,:,:,:)
11426  logical, allocatable:: both_negative(:,:,:,:,:)
11427 
11428 
11429  continue
11430  if (present(negative_support)) then
11431  negative_support_on = negative_support
11432  else
11433  negative_support_on = .true.
11434  end if
11435 
11436  err_flag = .false.
11437 
11438 
11439  answer_shape = shape(answer)
11440  check_shape = shape(check)
11441 
11442  consist_shape = answer_shape == check_shape
11443 
11444  if (.not. all(consist_shape)) then
11445  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11446  write(*,*) ''
11447  write(*,*) ' shape of check is (', check_shape, ')'
11448  write(*,*) ' is INCORRECT'
11449  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11450 
11451  call abortprogram('')
11452  end if
11453 
11454 
11455  allocate( mask_array( &
11456  & answer_shape(1), &
11457 
11458  & answer_shape(2), &
11459 
11460  & answer_shape(3), &
11461 
11462  & answer_shape(4), &
11463 
11464  & answer_shape(5) ) &
11465  & )
11466 
11467  allocate( judge( &
11468  & answer_shape(1), &
11469 
11470  & answer_shape(2), &
11471 
11472  & answer_shape(3), &
11473 
11474  & answer_shape(4), &
11475 
11476  & answer_shape(5) ) &
11477  & )
11478 
11479  allocate( judge_rev( &
11480  & answer_shape(1), &
11481 
11482  & answer_shape(2), &
11483 
11484  & answer_shape(3), &
11485 
11486  & answer_shape(4), &
11487 
11488  & answer_shape(5) ) &
11489  & )
11490 
11491  allocate( answer_negative( &
11492  & answer_shape(1), &
11493 
11494  & answer_shape(2), &
11495 
11496  & answer_shape(3), &
11497 
11498  & answer_shape(4), &
11499 
11500  & answer_shape(5) ) &
11501  & )
11502 
11503  allocate( check_negative( &
11504  & answer_shape(1), &
11505 
11506  & answer_shape(2), &
11507 
11508  & answer_shape(3), &
11509 
11510  & answer_shape(4), &
11511 
11512  & answer_shape(5) ) &
11513  & )
11514 
11515  allocate( both_negative( &
11516  & answer_shape(1), &
11517 
11518  & answer_shape(2), &
11519 
11520  & answer_shape(3), &
11521 
11522  & answer_shape(4), &
11523 
11524  & answer_shape(5) ) &
11525  & )
11526 
11527  answer_negative = answer < 0.0
11528  check_negative = check < 0.0
11529  both_negative = answer_negative .and. check_negative
11530  if (.not. negative_support_on) both_negative = .false.
11531 
11532  judge = answer < check
11533  where (both_negative) judge = .not. judge
11534 
11535  judge_rev = .not. judge
11536  err_flag = any(judge_rev)
11537  mask_array = 1
11538  pos = maxloc(mask_array, judge_rev)
11539 
11540  if (err_flag) then
11541 
11542  wrong = check( &
11543  & pos(1), &
11544 
11545  & pos(2), &
11546 
11547  & pos(3), &
11548 
11549  & pos(4), &
11550 
11551  & pos(5) )
11552 
11553  right = answer( &
11554  & pos(1), &
11555 
11556  & pos(2), &
11557 
11558  & pos(3), &
11559 
11560  & pos(4), &
11561 
11562  & pos(5) )
11563 
11564  write(unit=pos_array(1), fmt="(i20)") pos(1)
11565 
11566  write(unit=pos_array(2), fmt="(i20)") pos(2)
11567 
11568  write(unit=pos_array(3), fmt="(i20)") pos(3)
11569 
11570  write(unit=pos_array(4), fmt="(i20)") pos(4)
11571 
11572  write(unit=pos_array(5), fmt="(i20)") pos(5)
11573 
11574 
11575  pos_str = '(' // &
11576  & trim(adjustl(pos_array(1))) // ',' // &
11577 
11578  & trim(adjustl(pos_array(2))) // ',' // &
11579 
11580  & trim(adjustl(pos_array(3))) // ',' // &
11581 
11582  & trim(adjustl(pos_array(4))) // ',' // &
11583 
11584  & trim(adjustl(pos_array(5))) // ')'
11585 
11586  if ( both_negative( &
11587  & pos(1), &
11588 
11589  & pos(2), &
11590 
11591  & pos(3), &
11592 
11593  & pos(4), &
11594 
11595  & pos(5) ) ) then
11596 
11597  abs_mes = 'ABSOLUTE value of'
11598  else
11599  abs_mes = ''
11600 
11601  end if
11602 
11603  end if
11604  deallocate(mask_array, judge, judge_rev)
11605  deallocate(answer_negative, check_negative, both_negative)
11606 
11607 
11608 
11609 
11610  if (err_flag) then
11611  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11612  write(*,*) ''
11613  write(*,*) ' ' // trim(abs_mes) // &
11614  & ' check' // trim(pos_str) // ' = ', wrong
11615  write(*,*) ' is NOT GREATER THAN'
11616  write(*,*) ' ' // trim(abs_mes) // &
11617  & ' answer' // trim(pos_str) // ' = ', right
11618 
11619  call abortprogram('')
11620  else
11621  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11622  end if
11623 
11624 
11625  end subroutine dctestassertgreaterthanreal5
11626 
11627 
11628  subroutine dctestassertgreaterthanreal6( &
11629  & message, answer, check, negative_support)
11630  use sysdep, only: abortprogram
11631  use dc_types, only: string, token
11632  implicit none
11633  character(*), intent(in):: message
11634  real, intent(in):: answer(:,:,:,:,:,:)
11635  real, intent(in):: check(:,:,:,:,:,:)
11636  logical, intent(in), optional:: negative_support
11637  logical:: err_flag
11638  logical:: negative_support_on
11639  character(STRING):: pos_str
11640  character(TOKEN):: abs_mes
11641  real:: wrong, right
11642 
11643  integer:: answer_shape(6), check_shape(6), pos(6)
11644  logical:: consist_shape(6)
11645  character(TOKEN):: pos_array(6)
11646  integer, allocatable:: mask_array(:,:,:,:,:,:)
11647  logical, allocatable:: judge(:,:,:,:,:,:)
11648  logical, allocatable:: judge_rev(:,:,:,:,:,:)
11649  logical, allocatable:: answer_negative(:,:,:,:,:,:)
11650  logical, allocatable:: check_negative(:,:,:,:,:,:)
11651  logical, allocatable:: both_negative(:,:,:,:,:,:)
11652 
11653 
11654  continue
11655  if (present(negative_support)) then
11656  negative_support_on = negative_support
11657  else
11658  negative_support_on = .true.
11659  end if
11660 
11661  err_flag = .false.
11662 
11663 
11664  answer_shape = shape(answer)
11665  check_shape = shape(check)
11666 
11667  consist_shape = answer_shape == check_shape
11668 
11669  if (.not. all(consist_shape)) then
11670  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11671  write(*,*) ''
11672  write(*,*) ' shape of check is (', check_shape, ')'
11673  write(*,*) ' is INCORRECT'
11674  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11675 
11676  call abortprogram('')
11677  end if
11678 
11679 
11680  allocate( mask_array( &
11681  & answer_shape(1), &
11682 
11683  & answer_shape(2), &
11684 
11685  & answer_shape(3), &
11686 
11687  & answer_shape(4), &
11688 
11689  & answer_shape(5), &
11690 
11691  & answer_shape(6) ) &
11692  & )
11693 
11694  allocate( judge( &
11695  & answer_shape(1), &
11696 
11697  & answer_shape(2), &
11698 
11699  & answer_shape(3), &
11700 
11701  & answer_shape(4), &
11702 
11703  & answer_shape(5), &
11704 
11705  & answer_shape(6) ) &
11706  & )
11707 
11708  allocate( judge_rev( &
11709  & answer_shape(1), &
11710 
11711  & answer_shape(2), &
11712 
11713  & answer_shape(3), &
11714 
11715  & answer_shape(4), &
11716 
11717  & answer_shape(5), &
11718 
11719  & answer_shape(6) ) &
11720  & )
11721 
11722  allocate( answer_negative( &
11723  & answer_shape(1), &
11724 
11725  & answer_shape(2), &
11726 
11727  & answer_shape(3), &
11728 
11729  & answer_shape(4), &
11730 
11731  & answer_shape(5), &
11732 
11733  & answer_shape(6) ) &
11734  & )
11735 
11736  allocate( check_negative( &
11737  & answer_shape(1), &
11738 
11739  & answer_shape(2), &
11740 
11741  & answer_shape(3), &
11742 
11743  & answer_shape(4), &
11744 
11745  & answer_shape(5), &
11746 
11747  & answer_shape(6) ) &
11748  & )
11749 
11750  allocate( both_negative( &
11751  & answer_shape(1), &
11752 
11753  & answer_shape(2), &
11754 
11755  & answer_shape(3), &
11756 
11757  & answer_shape(4), &
11758 
11759  & answer_shape(5), &
11760 
11761  & answer_shape(6) ) &
11762  & )
11763 
11764  answer_negative = answer < 0.0
11765  check_negative = check < 0.0
11766  both_negative = answer_negative .and. check_negative
11767  if (.not. negative_support_on) both_negative = .false.
11768 
11769  judge = answer < check
11770  where (both_negative) judge = .not. judge
11771 
11772  judge_rev = .not. judge
11773  err_flag = any(judge_rev)
11774  mask_array = 1
11775  pos = maxloc(mask_array, judge_rev)
11776 
11777  if (err_flag) then
11778 
11779  wrong = check( &
11780  & pos(1), &
11781 
11782  & pos(2), &
11783 
11784  & pos(3), &
11785 
11786  & pos(4), &
11787 
11788  & pos(5), &
11789 
11790  & pos(6) )
11791 
11792  right = answer( &
11793  & pos(1), &
11794 
11795  & pos(2), &
11796 
11797  & pos(3), &
11798 
11799  & pos(4), &
11800 
11801  & pos(5), &
11802 
11803  & pos(6) )
11804 
11805  write(unit=pos_array(1), fmt="(i20)") pos(1)
11806 
11807  write(unit=pos_array(2), fmt="(i20)") pos(2)
11808 
11809  write(unit=pos_array(3), fmt="(i20)") pos(3)
11810 
11811  write(unit=pos_array(4), fmt="(i20)") pos(4)
11812 
11813  write(unit=pos_array(5), fmt="(i20)") pos(5)
11814 
11815  write(unit=pos_array(6), fmt="(i20)") pos(6)
11816 
11817 
11818  pos_str = '(' // &
11819  & trim(adjustl(pos_array(1))) // ',' // &
11820 
11821  & trim(adjustl(pos_array(2))) // ',' // &
11822 
11823  & trim(adjustl(pos_array(3))) // ',' // &
11824 
11825  & trim(adjustl(pos_array(4))) // ',' // &
11826 
11827  & trim(adjustl(pos_array(5))) // ',' // &
11828 
11829  & trim(adjustl(pos_array(6))) // ')'
11830 
11831  if ( both_negative( &
11832  & pos(1), &
11833 
11834  & pos(2), &
11835 
11836  & pos(3), &
11837 
11838  & pos(4), &
11839 
11840  & pos(5), &
11841 
11842  & pos(6) ) ) then
11843 
11844  abs_mes = 'ABSOLUTE value of'
11845  else
11846  abs_mes = ''
11847 
11848  end if
11849 
11850  end if
11851  deallocate(mask_array, judge, judge_rev)
11852  deallocate(answer_negative, check_negative, both_negative)
11853 
11854 
11855 
11856 
11857  if (err_flag) then
11858  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11859  write(*,*) ''
11860  write(*,*) ' ' // trim(abs_mes) // &
11861  & ' check' // trim(pos_str) // ' = ', wrong
11862  write(*,*) ' is NOT GREATER THAN'
11863  write(*,*) ' ' // trim(abs_mes) // &
11864  & ' answer' // trim(pos_str) // ' = ', right
11865 
11866  call abortprogram('')
11867  else
11868  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11869  end if
11870 
11871 
11872  end subroutine dctestassertgreaterthanreal6
11873 
11874 
11875  subroutine dctestassertgreaterthanreal7( &
11876  & message, answer, check, negative_support)
11877  use sysdep, only: abortprogram
11878  use dc_types, only: string, token
11879  implicit none
11880  character(*), intent(in):: message
11881  real, intent(in):: answer(:,:,:,:,:,:,:)
11882  real, intent(in):: check(:,:,:,:,:,:,:)
11883  logical, intent(in), optional:: negative_support
11884  logical:: err_flag
11885  logical:: negative_support_on
11886  character(STRING):: pos_str
11887  character(TOKEN):: abs_mes
11888  real:: wrong, right
11889 
11890  integer:: answer_shape(7), check_shape(7), pos(7)
11891  logical:: consist_shape(7)
11892  character(TOKEN):: pos_array(7)
11893  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
11894  logical, allocatable:: judge(:,:,:,:,:,:,:)
11895  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
11896  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
11897  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
11898  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
11899 
11900 
11901  continue
11902  if (present(negative_support)) then
11903  negative_support_on = negative_support
11904  else
11905  negative_support_on = .true.
11906  end if
11907 
11908  err_flag = .false.
11909 
11910 
11911  answer_shape = shape(answer)
11912  check_shape = shape(check)
11913 
11914  consist_shape = answer_shape == check_shape
11915 
11916  if (.not. all(consist_shape)) then
11917  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11918  write(*,*) ''
11919  write(*,*) ' shape of check is (', check_shape, ')'
11920  write(*,*) ' is INCORRECT'
11921  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11922 
11923  call abortprogram('')
11924  end if
11925 
11926 
11927  allocate( mask_array( &
11928  & answer_shape(1), &
11929 
11930  & answer_shape(2), &
11931 
11932  & answer_shape(3), &
11933 
11934  & answer_shape(4), &
11935 
11936  & answer_shape(5), &
11937 
11938  & answer_shape(6), &
11939 
11940  & answer_shape(7) ) &
11941  & )
11942 
11943  allocate( judge( &
11944  & answer_shape(1), &
11945 
11946  & answer_shape(2), &
11947 
11948  & answer_shape(3), &
11949 
11950  & answer_shape(4), &
11951 
11952  & answer_shape(5), &
11953 
11954  & answer_shape(6), &
11955 
11956  & answer_shape(7) ) &
11957  & )
11958 
11959  allocate( judge_rev( &
11960  & answer_shape(1), &
11961 
11962  & answer_shape(2), &
11963 
11964  & answer_shape(3), &
11965 
11966  & answer_shape(4), &
11967 
11968  & answer_shape(5), &
11969 
11970  & answer_shape(6), &
11971 
11972  & answer_shape(7) ) &
11973  & )
11974 
11975  allocate( answer_negative( &
11976  & answer_shape(1), &
11977 
11978  & answer_shape(2), &
11979 
11980  & answer_shape(3), &
11981 
11982  & answer_shape(4), &
11983 
11984  & answer_shape(5), &
11985 
11986  & answer_shape(6), &
11987 
11988  & answer_shape(7) ) &
11989  & )
11990 
11991  allocate( check_negative( &
11992  & answer_shape(1), &
11993 
11994  & answer_shape(2), &
11995 
11996  & answer_shape(3), &
11997 
11998  & answer_shape(4), &
11999 
12000  & answer_shape(5), &
12001 
12002  & answer_shape(6), &
12003 
12004  & answer_shape(7) ) &
12005  & )
12006 
12007  allocate( both_negative( &
12008  & answer_shape(1), &
12009 
12010  & answer_shape(2), &
12011 
12012  & answer_shape(3), &
12013 
12014  & answer_shape(4), &
12015 
12016  & answer_shape(5), &
12017 
12018  & answer_shape(6), &
12019 
12020  & answer_shape(7) ) &
12021  & )
12022 
12023  answer_negative = answer < 0.0
12024  check_negative = check < 0.0
12025  both_negative = answer_negative .and. check_negative
12026  if (.not. negative_support_on) both_negative = .false.
12027 
12028  judge = answer < check
12029  where (both_negative) judge = .not. judge
12030 
12031  judge_rev = .not. judge
12032  err_flag = any(judge_rev)
12033  mask_array = 1
12034  pos = maxloc(mask_array, judge_rev)
12035 
12036  if (err_flag) then
12037 
12038  wrong = check( &
12039  & pos(1), &
12040 
12041  & pos(2), &
12042 
12043  & pos(3), &
12044 
12045  & pos(4), &
12046 
12047  & pos(5), &
12048 
12049  & pos(6), &
12050 
12051  & pos(7) )
12052 
12053  right = answer( &
12054  & pos(1), &
12055 
12056  & pos(2), &
12057 
12058  & pos(3), &
12059 
12060  & pos(4), &
12061 
12062  & pos(5), &
12063 
12064  & pos(6), &
12065 
12066  & pos(7) )
12067 
12068  write(unit=pos_array(1), fmt="(i20)") pos(1)
12069 
12070  write(unit=pos_array(2), fmt="(i20)") pos(2)
12071 
12072  write(unit=pos_array(3), fmt="(i20)") pos(3)
12073 
12074  write(unit=pos_array(4), fmt="(i20)") pos(4)
12075 
12076  write(unit=pos_array(5), fmt="(i20)") pos(5)
12077 
12078  write(unit=pos_array(6), fmt="(i20)") pos(6)
12079 
12080  write(unit=pos_array(7), fmt="(i20)") pos(7)
12081 
12082 
12083  pos_str = '(' // &
12084  & trim(adjustl(pos_array(1))) // ',' // &
12085 
12086  & trim(adjustl(pos_array(2))) // ',' // &
12087 
12088  & trim(adjustl(pos_array(3))) // ',' // &
12089 
12090  & trim(adjustl(pos_array(4))) // ',' // &
12091 
12092  & trim(adjustl(pos_array(5))) // ',' // &
12093 
12094  & trim(adjustl(pos_array(6))) // ',' // &
12095 
12096  & trim(adjustl(pos_array(7))) // ')'
12097 
12098  if ( both_negative( &
12099  & pos(1), &
12100 
12101  & pos(2), &
12102 
12103  & pos(3), &
12104 
12105  & pos(4), &
12106 
12107  & pos(5), &
12108 
12109  & pos(6), &
12110 
12111  & pos(7) ) ) then
12112 
12113  abs_mes = 'ABSOLUTE value of'
12114  else
12115  abs_mes = ''
12116 
12117  end if
12118 
12119  end if
12120  deallocate(mask_array, judge, judge_rev)
12121  deallocate(answer_negative, check_negative, both_negative)
12122 
12123 
12124 
12125 
12126  if (err_flag) then
12127  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12128  write(*,*) ''
12129  write(*,*) ' ' // trim(abs_mes) // &
12130  & ' check' // trim(pos_str) // ' = ', wrong
12131  write(*,*) ' is NOT GREATER THAN'
12132  write(*,*) ' ' // trim(abs_mes) // &
12133  & ' answer' // trim(pos_str) // ' = ', right
12134 
12135  call abortprogram('')
12136  else
12137  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12138  end if
12139 
12140 
12141  end subroutine dctestassertgreaterthanreal7
12142 
12143 
12144  subroutine dctestassertgreaterthandouble0( &
12145  & message, answer, check, negative_support)
12146  use sysdep, only: abortprogram
12147  use dc_types, only: string, token
12148  implicit none
12149  character(*), intent(in):: message
12150  real(DP), intent(in):: answer
12151  real(DP), intent(in):: check
12152  logical, intent(in), optional:: negative_support
12153  logical:: err_flag
12154  logical:: negative_support_on
12155  character(STRING):: pos_str
12156  character(TOKEN):: abs_mes
12157  real(DP):: wrong, right
12158 
12159 
12160 
12161  continue
12162  if (present(negative_support)) then
12163  negative_support_on = negative_support
12164  else
12165  negative_support_on = .true.
12166  end if
12167 
12168  err_flag = .false.
12169 
12170 
12171  err_flag = .not. answer < check
12172  abs_mes = ''
12173 
12174  if ( answer < 0.0_dp &
12175  & .and. check < 0.0_dp &
12176  & .and. negative_support_on ) then
12177 
12178  err_flag = .not. err_flag
12179  abs_mes = 'ABSOLUTE value of'
12180  end if
12181 
12182  wrong = check
12183  right = answer
12184  pos_str = ''
12185 
12186 
12187 
12188 
12189  if (err_flag) then
12190  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12191  write(*,*) ''
12192  write(*,*) ' ' // trim(abs_mes) // &
12193  & ' check' // trim(pos_str) // ' = ', wrong
12194  write(*,*) ' is NOT GREATER THAN'
12195  write(*,*) ' ' // trim(abs_mes) // &
12196  & ' answer' // trim(pos_str) // ' = ', right
12197 
12198  call abortprogram('')
12199  else
12200  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12201  end if
12202 
12203 
12204  end subroutine dctestassertgreaterthandouble0
12205 
12206 
12207  subroutine dctestassertgreaterthandouble1( &
12208  & message, answer, check, negative_support)
12209  use sysdep, only: abortprogram
12210  use dc_types, only: string, token
12211  implicit none
12212  character(*), intent(in):: message
12213  real(DP), intent(in):: answer(:)
12214  real(DP), intent(in):: check(:)
12215  logical, intent(in), optional:: negative_support
12216  logical:: err_flag
12217  logical:: negative_support_on
12218  character(STRING):: pos_str
12219  character(TOKEN):: abs_mes
12220  real(DP):: wrong, right
12221 
12222  integer:: answer_shape(1), check_shape(1), pos(1)
12223  logical:: consist_shape(1)
12224  character(TOKEN):: pos_array(1)
12225  integer, allocatable:: mask_array(:)
12226  logical, allocatable:: judge(:)
12227  logical, allocatable:: judge_rev(:)
12228  logical, allocatable:: answer_negative(:)
12229  logical, allocatable:: check_negative(:)
12230  logical, allocatable:: both_negative(:)
12231 
12232 
12233  continue
12234  if (present(negative_support)) then
12235  negative_support_on = negative_support
12236  else
12237  negative_support_on = .true.
12238  end if
12239 
12240  err_flag = .false.
12241 
12242 
12243  answer_shape = shape(answer)
12244  check_shape = shape(check)
12245 
12246  consist_shape = answer_shape == check_shape
12247 
12248  if (.not. all(consist_shape)) then
12249  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12250  write(*,*) ''
12251  write(*,*) ' shape of check is (', check_shape, ')'
12252  write(*,*) ' is INCORRECT'
12253  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12254 
12255  call abortprogram('')
12256  end if
12257 
12258 
12259  allocate( mask_array( &
12260 
12261  & answer_shape(1) ) &
12262  & )
12263 
12264  allocate( judge( &
12265 
12266  & answer_shape(1) ) &
12267  & )
12268 
12269  allocate( judge_rev( &
12270 
12271  & answer_shape(1) ) &
12272  & )
12273 
12274  allocate( answer_negative( &
12275 
12276  & answer_shape(1) ) &
12277  & )
12278 
12279  allocate( check_negative( &
12280 
12281  & answer_shape(1) ) &
12282  & )
12283 
12284  allocate( both_negative( &
12285 
12286  & answer_shape(1) ) &
12287  & )
12288 
12289  answer_negative = answer < 0.0_dp
12290  check_negative = check < 0.0_dp
12291  both_negative = answer_negative .and. check_negative
12292  if (.not. negative_support_on) both_negative = .false.
12293 
12294  judge = answer < check
12295  where (both_negative) judge = .not. judge
12296 
12297  judge_rev = .not. judge
12298  err_flag = any(judge_rev)
12299  mask_array = 1
12300  pos = maxloc(mask_array, judge_rev)
12301 
12302  if (err_flag) then
12303 
12304  wrong = check( &
12305 
12306  & pos(1) )
12307 
12308  right = answer( &
12309 
12310  & pos(1) )
12311 
12312  write(unit=pos_array(1), fmt="(i20)") pos(1)
12313 
12314 
12315  pos_str = '(' // &
12316 
12317  & trim(adjustl(pos_array(1))) // ')'
12318 
12319  if ( both_negative( &
12320 
12321  & pos(1) ) ) then
12322 
12323  abs_mes = 'ABSOLUTE value of'
12324  else
12325  abs_mes = ''
12326 
12327  end if
12328 
12329  end if
12330  deallocate(mask_array, judge, judge_rev)
12331  deallocate(answer_negative, check_negative, both_negative)
12332 
12333 
12334 
12335 
12336  if (err_flag) then
12337  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12338  write(*,*) ''
12339  write(*,*) ' ' // trim(abs_mes) // &
12340  & ' check' // trim(pos_str) // ' = ', wrong
12341  write(*,*) ' is NOT GREATER THAN'
12342  write(*,*) ' ' // trim(abs_mes) // &
12343  & ' answer' // trim(pos_str) // ' = ', right
12344 
12345  call abortprogram('')
12346  else
12347  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12348  end if
12349 
12350 
12351  end subroutine dctestassertgreaterthandouble1
12352 
12353 
12354  subroutine dctestassertgreaterthandouble2( &
12355  & message, answer, check, negative_support)
12356  use sysdep, only: abortprogram
12357  use dc_types, only: string, token
12358  implicit none
12359  character(*), intent(in):: message
12360  real(DP), intent(in):: answer(:,:)
12361  real(DP), intent(in):: check(:,:)
12362  logical, intent(in), optional:: negative_support
12363  logical:: err_flag
12364  logical:: negative_support_on
12365  character(STRING):: pos_str
12366  character(TOKEN):: abs_mes
12367  real(DP):: wrong, right
12368 
12369  integer:: answer_shape(2), check_shape(2), pos(2)
12370  logical:: consist_shape(2)
12371  character(TOKEN):: pos_array(2)
12372  integer, allocatable:: mask_array(:,:)
12373  logical, allocatable:: judge(:,:)
12374  logical, allocatable:: judge_rev(:,:)
12375  logical, allocatable:: answer_negative(:,:)
12376  logical, allocatable:: check_negative(:,:)
12377  logical, allocatable:: both_negative(:,:)
12378 
12379 
12380  continue
12381  if (present(negative_support)) then
12382  negative_support_on = negative_support
12383  else
12384  negative_support_on = .true.
12385  end if
12386 
12387  err_flag = .false.
12388 
12389 
12390  answer_shape = shape(answer)
12391  check_shape = shape(check)
12392 
12393  consist_shape = answer_shape == check_shape
12394 
12395  if (.not. all(consist_shape)) then
12396  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12397  write(*,*) ''
12398  write(*,*) ' shape of check is (', check_shape, ')'
12399  write(*,*) ' is INCORRECT'
12400  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12401 
12402  call abortprogram('')
12403  end if
12404 
12405 
12406  allocate( mask_array( &
12407  & answer_shape(1), &
12408 
12409  & answer_shape(2) ) &
12410  & )
12411 
12412  allocate( judge( &
12413  & answer_shape(1), &
12414 
12415  & answer_shape(2) ) &
12416  & )
12417 
12418  allocate( judge_rev( &
12419  & answer_shape(1), &
12420 
12421  & answer_shape(2) ) &
12422  & )
12423 
12424  allocate( answer_negative( &
12425  & answer_shape(1), &
12426 
12427  & answer_shape(2) ) &
12428  & )
12429 
12430  allocate( check_negative( &
12431  & answer_shape(1), &
12432 
12433  & answer_shape(2) ) &
12434  & )
12435 
12436  allocate( both_negative( &
12437  & answer_shape(1), &
12438 
12439  & answer_shape(2) ) &
12440  & )
12441 
12442  answer_negative = answer < 0.0_dp
12443  check_negative = check < 0.0_dp
12444  both_negative = answer_negative .and. check_negative
12445  if (.not. negative_support_on) both_negative = .false.
12446 
12447  judge = answer < check
12448  where (both_negative) judge = .not. judge
12449 
12450  judge_rev = .not. judge
12451  err_flag = any(judge_rev)
12452  mask_array = 1
12453  pos = maxloc(mask_array, judge_rev)
12454 
12455  if (err_flag) then
12456 
12457  wrong = check( &
12458  & pos(1), &
12459 
12460  & pos(2) )
12461 
12462  right = answer( &
12463  & pos(1), &
12464 
12465  & pos(2) )
12466 
12467  write(unit=pos_array(1), fmt="(i20)") pos(1)
12468 
12469  write(unit=pos_array(2), fmt="(i20)") pos(2)
12470 
12471 
12472  pos_str = '(' // &
12473  & trim(adjustl(pos_array(1))) // ',' // &
12474 
12475  & trim(adjustl(pos_array(2))) // ')'
12476 
12477  if ( both_negative( &
12478  & pos(1), &
12479 
12480  & pos(2) ) ) then
12481 
12482  abs_mes = 'ABSOLUTE value of'
12483  else
12484  abs_mes = ''
12485 
12486  end if
12487 
12488  end if
12489  deallocate(mask_array, judge, judge_rev)
12490  deallocate(answer_negative, check_negative, both_negative)
12491 
12492 
12493 
12494 
12495  if (err_flag) then
12496  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12497  write(*,*) ''
12498  write(*,*) ' ' // trim(abs_mes) // &
12499  & ' check' // trim(pos_str) // ' = ', wrong
12500  write(*,*) ' is NOT GREATER THAN'
12501  write(*,*) ' ' // trim(abs_mes) // &
12502  & ' answer' // trim(pos_str) // ' = ', right
12503 
12504  call abortprogram('')
12505  else
12506  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12507  end if
12508 
12509 
12510  end subroutine dctestassertgreaterthandouble2
12511 
12512 
12513  subroutine dctestassertgreaterthandouble3( &
12514  & message, answer, check, negative_support)
12515  use sysdep, only: abortprogram
12516  use dc_types, only: string, token
12517  implicit none
12518  character(*), intent(in):: message
12519  real(DP), intent(in):: answer(:,:,:)
12520  real(DP), intent(in):: check(:,:,:)
12521  logical, intent(in), optional:: negative_support
12522  logical:: err_flag
12523  logical:: negative_support_on
12524  character(STRING):: pos_str
12525  character(TOKEN):: abs_mes
12526  real(DP):: wrong, right
12527 
12528  integer:: answer_shape(3), check_shape(3), pos(3)
12529  logical:: consist_shape(3)
12530  character(TOKEN):: pos_array(3)
12531  integer, allocatable:: mask_array(:,:,:)
12532  logical, allocatable:: judge(:,:,:)
12533  logical, allocatable:: judge_rev(:,:,:)
12534  logical, allocatable:: answer_negative(:,:,:)
12535  logical, allocatable:: check_negative(:,:,:)
12536  logical, allocatable:: both_negative(:,:,:)
12537 
12538 
12539  continue
12540  if (present(negative_support)) then
12541  negative_support_on = negative_support
12542  else
12543  negative_support_on = .true.
12544  end if
12545 
12546  err_flag = .false.
12547 
12548 
12549  answer_shape = shape(answer)
12550  check_shape = shape(check)
12551 
12552  consist_shape = answer_shape == check_shape
12553 
12554  if (.not. all(consist_shape)) then
12555  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12556  write(*,*) ''
12557  write(*,*) ' shape of check is (', check_shape, ')'
12558  write(*,*) ' is INCORRECT'
12559  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12560 
12561  call abortprogram('')
12562  end if
12563 
12564 
12565  allocate( mask_array( &
12566  & answer_shape(1), &
12567 
12568  & answer_shape(2), &
12569 
12570  & answer_shape(3) ) &
12571  & )
12572 
12573  allocate( judge( &
12574  & answer_shape(1), &
12575 
12576  & answer_shape(2), &
12577 
12578  & answer_shape(3) ) &
12579  & )
12580 
12581  allocate( judge_rev( &
12582  & answer_shape(1), &
12583 
12584  & answer_shape(2), &
12585 
12586  & answer_shape(3) ) &
12587  & )
12588 
12589  allocate( answer_negative( &
12590  & answer_shape(1), &
12591 
12592  & answer_shape(2), &
12593 
12594  & answer_shape(3) ) &
12595  & )
12596 
12597  allocate( check_negative( &
12598  & answer_shape(1), &
12599 
12600  & answer_shape(2), &
12601 
12602  & answer_shape(3) ) &
12603  & )
12604 
12605  allocate( both_negative( &
12606  & answer_shape(1), &
12607 
12608  & answer_shape(2), &
12609 
12610  & answer_shape(3) ) &
12611  & )
12612 
12613  answer_negative = answer < 0.0_dp
12614  check_negative = check < 0.0_dp
12615  both_negative = answer_negative .and. check_negative
12616  if (.not. negative_support_on) both_negative = .false.
12617 
12618  judge = answer < check
12619  where (both_negative) judge = .not. judge
12620 
12621  judge_rev = .not. judge
12622  err_flag = any(judge_rev)
12623  mask_array = 1
12624  pos = maxloc(mask_array, judge_rev)
12625 
12626  if (err_flag) then
12627 
12628  wrong = check( &
12629  & pos(1), &
12630 
12631  & pos(2), &
12632 
12633  & pos(3) )
12634 
12635  right = answer( &
12636  & pos(1), &
12637 
12638  & pos(2), &
12639 
12640  & pos(3) )
12641 
12642  write(unit=pos_array(1), fmt="(i20)") pos(1)
12643 
12644  write(unit=pos_array(2), fmt="(i20)") pos(2)
12645 
12646  write(unit=pos_array(3), fmt="(i20)") pos(3)
12647 
12648 
12649  pos_str = '(' // &
12650  & trim(adjustl(pos_array(1))) // ',' // &
12651 
12652  & trim(adjustl(pos_array(2))) // ',' // &
12653 
12654  & trim(adjustl(pos_array(3))) // ')'
12655 
12656  if ( both_negative( &
12657  & pos(1), &
12658 
12659  & pos(2), &
12660 
12661  & pos(3) ) ) then
12662 
12663  abs_mes = 'ABSOLUTE value of'
12664  else
12665  abs_mes = ''
12666 
12667  end if
12668 
12669  end if
12670  deallocate(mask_array, judge, judge_rev)
12671  deallocate(answer_negative, check_negative, both_negative)
12672 
12673 
12674 
12675 
12676  if (err_flag) then
12677  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12678  write(*,*) ''
12679  write(*,*) ' ' // trim(abs_mes) // &
12680  & ' check' // trim(pos_str) // ' = ', wrong
12681  write(*,*) ' is NOT GREATER THAN'
12682  write(*,*) ' ' // trim(abs_mes) // &
12683  & ' answer' // trim(pos_str) // ' = ', right
12684 
12685  call abortprogram('')
12686  else
12687  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12688  end if
12689 
12690 
12691  end subroutine dctestassertgreaterthandouble3
12692 
12693 
12694  subroutine dctestassertgreaterthandouble4( &
12695  & message, answer, check, negative_support)
12696  use sysdep, only: abortprogram
12697  use dc_types, only: string, token
12698  implicit none
12699  character(*), intent(in):: message
12700  real(DP), intent(in):: answer(:,:,:,:)
12701  real(DP), intent(in):: check(:,:,:,:)
12702  logical, intent(in), optional:: negative_support
12703  logical:: err_flag
12704  logical:: negative_support_on
12705  character(STRING):: pos_str
12706  character(TOKEN):: abs_mes
12707  real(DP):: wrong, right
12708 
12709  integer:: answer_shape(4), check_shape(4), pos(4)
12710  logical:: consist_shape(4)
12711  character(TOKEN):: pos_array(4)
12712  integer, allocatable:: mask_array(:,:,:,:)
12713  logical, allocatable:: judge(:,:,:,:)
12714  logical, allocatable:: judge_rev(:,:,:,:)
12715  logical, allocatable:: answer_negative(:,:,:,:)
12716  logical, allocatable:: check_negative(:,:,:,:)
12717  logical, allocatable:: both_negative(:,:,:,:)
12718 
12719 
12720  continue
12721  if (present(negative_support)) then
12722  negative_support_on = negative_support
12723  else
12724  negative_support_on = .true.
12725  end if
12726 
12727  err_flag = .false.
12728 
12729 
12730  answer_shape = shape(answer)
12731  check_shape = shape(check)
12732 
12733  consist_shape = answer_shape == check_shape
12734 
12735  if (.not. all(consist_shape)) then
12736  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12737  write(*,*) ''
12738  write(*,*) ' shape of check is (', check_shape, ')'
12739  write(*,*) ' is INCORRECT'
12740  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12741 
12742  call abortprogram('')
12743  end if
12744 
12745 
12746  allocate( mask_array( &
12747  & answer_shape(1), &
12748 
12749  & answer_shape(2), &
12750 
12751  & answer_shape(3), &
12752 
12753  & answer_shape(4) ) &
12754  & )
12755 
12756  allocate( judge( &
12757  & answer_shape(1), &
12758 
12759  & answer_shape(2), &
12760 
12761  & answer_shape(3), &
12762 
12763  & answer_shape(4) ) &
12764  & )
12765 
12766  allocate( judge_rev( &
12767  & answer_shape(1), &
12768 
12769  & answer_shape(2), &
12770 
12771  & answer_shape(3), &
12772 
12773  & answer_shape(4) ) &
12774  & )
12775 
12776  allocate( answer_negative( &
12777  & answer_shape(1), &
12778 
12779  & answer_shape(2), &
12780 
12781  & answer_shape(3), &
12782 
12783  & answer_shape(4) ) &
12784  & )
12785 
12786  allocate( check_negative( &
12787  & answer_shape(1), &
12788 
12789  & answer_shape(2), &
12790 
12791  & answer_shape(3), &
12792 
12793  & answer_shape(4) ) &
12794  & )
12795 
12796  allocate( both_negative( &
12797  & answer_shape(1), &
12798 
12799  & answer_shape(2), &
12800 
12801  & answer_shape(3), &
12802 
12803  & answer_shape(4) ) &
12804  & )
12805 
12806  answer_negative = answer < 0.0_dp
12807  check_negative = check < 0.0_dp
12808  both_negative = answer_negative .and. check_negative
12809  if (.not. negative_support_on) both_negative = .false.
12810 
12811  judge = answer < check
12812  where (both_negative) judge = .not. judge
12813 
12814  judge_rev = .not. judge
12815  err_flag = any(judge_rev)
12816  mask_array = 1
12817  pos = maxloc(mask_array, judge_rev)
12818 
12819  if (err_flag) then
12820 
12821  wrong = check( &
12822  & pos(1), &
12823 
12824  & pos(2), &
12825 
12826  & pos(3), &
12827 
12828  & pos(4) )
12829 
12830  right = answer( &
12831  & pos(1), &
12832 
12833  & pos(2), &
12834 
12835  & pos(3), &
12836 
12837  & pos(4) )
12838 
12839  write(unit=pos_array(1), fmt="(i20)") pos(1)
12840 
12841  write(unit=pos_array(2), fmt="(i20)") pos(2)
12842 
12843  write(unit=pos_array(3), fmt="(i20)") pos(3)
12844 
12845  write(unit=pos_array(4), fmt="(i20)") pos(4)
12846 
12847 
12848  pos_str = '(' // &
12849  & trim(adjustl(pos_array(1))) // ',' // &
12850 
12851  & trim(adjustl(pos_array(2))) // ',' // &
12852 
12853  & trim(adjustl(pos_array(3))) // ',' // &
12854 
12855  & trim(adjustl(pos_array(4))) // ')'
12856 
12857  if ( both_negative( &
12858  & pos(1), &
12859 
12860  & pos(2), &
12861 
12862  & pos(3), &
12863 
12864  & pos(4) ) ) then
12865 
12866  abs_mes = 'ABSOLUTE value of'
12867  else
12868  abs_mes = ''
12869 
12870  end if
12871 
12872  end if
12873  deallocate(mask_array, judge, judge_rev)
12874  deallocate(answer_negative, check_negative, both_negative)
12875 
12876 
12877 
12878 
12879  if (err_flag) then
12880  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12881  write(*,*) ''
12882  write(*,*) ' ' // trim(abs_mes) // &
12883  & ' check' // trim(pos_str) // ' = ', wrong
12884  write(*,*) ' is NOT GREATER THAN'
12885  write(*,*) ' ' // trim(abs_mes) // &
12886  & ' answer' // trim(pos_str) // ' = ', right
12887 
12888  call abortprogram('')
12889  else
12890  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12891  end if
12892 
12893 
12894  end subroutine dctestassertgreaterthandouble4
12895 
12896 
12897  subroutine dctestassertgreaterthandouble5( &
12898  & message, answer, check, negative_support)
12899  use sysdep, only: abortprogram
12900  use dc_types, only: string, token
12901  implicit none
12902  character(*), intent(in):: message
12903  real(DP), intent(in):: answer(:,:,:,:,:)
12904  real(DP), intent(in):: check(:,:,:,:,:)
12905  logical, intent(in), optional:: negative_support
12906  logical:: err_flag
12907  logical:: negative_support_on
12908  character(STRING):: pos_str
12909  character(TOKEN):: abs_mes
12910  real(DP):: wrong, right
12911 
12912  integer:: answer_shape(5), check_shape(5), pos(5)
12913  logical:: consist_shape(5)
12914  character(TOKEN):: pos_array(5)
12915  integer, allocatable:: mask_array(:,:,:,:,:)
12916  logical, allocatable:: judge(:,:,:,:,:)
12917  logical, allocatable:: judge_rev(:,:,:,:,:)
12918  logical, allocatable:: answer_negative(:,:,:,:,:)
12919  logical, allocatable:: check_negative(:,:,:,:,:)
12920  logical, allocatable:: both_negative(:,:,:,:,:)
12921 
12922 
12923  continue
12924  if (present(negative_support)) then
12925  negative_support_on = negative_support
12926  else
12927  negative_support_on = .true.
12928  end if
12929 
12930  err_flag = .false.
12931 
12932 
12933  answer_shape = shape(answer)
12934  check_shape = shape(check)
12935 
12936  consist_shape = answer_shape == check_shape
12937 
12938  if (.not. all(consist_shape)) then
12939  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12940  write(*,*) ''
12941  write(*,*) ' shape of check is (', check_shape, ')'
12942  write(*,*) ' is INCORRECT'
12943  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12944 
12945  call abortprogram('')
12946  end if
12947 
12948 
12949  allocate( mask_array( &
12950  & answer_shape(1), &
12951 
12952  & answer_shape(2), &
12953 
12954  & answer_shape(3), &
12955 
12956  & answer_shape(4), &
12957 
12958  & answer_shape(5) ) &
12959  & )
12960 
12961  allocate( judge( &
12962  & answer_shape(1), &
12963 
12964  & answer_shape(2), &
12965 
12966  & answer_shape(3), &
12967 
12968  & answer_shape(4), &
12969 
12970  & answer_shape(5) ) &
12971  & )
12972 
12973  allocate( judge_rev( &
12974  & answer_shape(1), &
12975 
12976  & answer_shape(2), &
12977 
12978  & answer_shape(3), &
12979 
12980  & answer_shape(4), &
12981 
12982  & answer_shape(5) ) &
12983  & )
12984 
12985  allocate( answer_negative( &
12986  & answer_shape(1), &
12987 
12988  & answer_shape(2), &
12989 
12990  & answer_shape(3), &
12991 
12992  & answer_shape(4), &
12993 
12994  & answer_shape(5) ) &
12995  & )
12996 
12997  allocate( check_negative( &
12998  & answer_shape(1), &
12999 
13000  & answer_shape(2), &
13001 
13002  & answer_shape(3), &
13003 
13004  & answer_shape(4), &
13005 
13006  & answer_shape(5) ) &
13007  & )
13008 
13009  allocate( both_negative( &
13010  & answer_shape(1), &
13011 
13012  & answer_shape(2), &
13013 
13014  & answer_shape(3), &
13015 
13016  & answer_shape(4), &
13017 
13018  & answer_shape(5) ) &
13019  & )
13020 
13021  answer_negative = answer < 0.0_dp
13022  check_negative = check < 0.0_dp
13023  both_negative = answer_negative .and. check_negative
13024  if (.not. negative_support_on) both_negative = .false.
13025 
13026  judge = answer < check
13027  where (both_negative) judge = .not. judge
13028 
13029  judge_rev = .not. judge
13030  err_flag = any(judge_rev)
13031  mask_array = 1
13032  pos = maxloc(mask_array, judge_rev)
13033 
13034  if (err_flag) then
13035 
13036  wrong = check( &
13037  & pos(1), &
13038 
13039  & pos(2), &
13040 
13041  & pos(3), &
13042 
13043  & pos(4), &
13044 
13045  & pos(5) )
13046 
13047  right = answer( &
13048  & pos(1), &
13049 
13050  & pos(2), &
13051 
13052  & pos(3), &
13053 
13054  & pos(4), &
13055 
13056  & pos(5) )
13057 
13058  write(unit=pos_array(1), fmt="(i20)") pos(1)
13059 
13060  write(unit=pos_array(2), fmt="(i20)") pos(2)
13061 
13062  write(unit=pos_array(3), fmt="(i20)") pos(3)
13063 
13064  write(unit=pos_array(4), fmt="(i20)") pos(4)
13065 
13066  write(unit=pos_array(5), fmt="(i20)") pos(5)
13067 
13068 
13069  pos_str = '(' // &
13070  & trim(adjustl(pos_array(1))) // ',' // &
13071 
13072  & trim(adjustl(pos_array(2))) // ',' // &
13073 
13074  & trim(adjustl(pos_array(3))) // ',' // &
13075 
13076  & trim(adjustl(pos_array(4))) // ',' // &
13077 
13078  & trim(adjustl(pos_array(5))) // ')'
13079 
13080  if ( both_negative( &
13081  & pos(1), &
13082 
13083  & pos(2), &
13084 
13085  & pos(3), &
13086 
13087  & pos(4), &
13088 
13089  & pos(5) ) ) then
13090 
13091  abs_mes = 'ABSOLUTE value of'
13092  else
13093  abs_mes = ''
13094 
13095  end if
13096 
13097  end if
13098  deallocate(mask_array, judge, judge_rev)
13099  deallocate(answer_negative, check_negative, both_negative)
13100 
13101 
13102 
13103 
13104  if (err_flag) then
13105  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13106  write(*,*) ''
13107  write(*,*) ' ' // trim(abs_mes) // &
13108  & ' check' // trim(pos_str) // ' = ', wrong
13109  write(*,*) ' is NOT GREATER THAN'
13110  write(*,*) ' ' // trim(abs_mes) // &
13111  & ' answer' // trim(pos_str) // ' = ', right
13112 
13113  call abortprogram('')
13114  else
13115  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13116  end if
13117 
13118 
13119  end subroutine dctestassertgreaterthandouble5
13120 
13121 
13122  subroutine dctestassertgreaterthandouble6( &
13123  & message, answer, check, negative_support)
13124  use sysdep, only: abortprogram
13125  use dc_types, only: string, token
13126  implicit none
13127  character(*), intent(in):: message
13128  real(DP), intent(in):: answer(:,:,:,:,:,:)
13129  real(DP), intent(in):: check(:,:,:,:,:,:)
13130  logical, intent(in), optional:: negative_support
13131  logical:: err_flag
13132  logical:: negative_support_on
13133  character(STRING):: pos_str
13134  character(TOKEN):: abs_mes
13135  real(DP):: wrong, right
13136 
13137  integer:: answer_shape(6), check_shape(6), pos(6)
13138  logical:: consist_shape(6)
13139  character(TOKEN):: pos_array(6)
13140  integer, allocatable:: mask_array(:,:,:,:,:,:)
13141  logical, allocatable:: judge(:,:,:,:,:,:)
13142  logical, allocatable:: judge_rev(:,:,:,:,:,:)
13143  logical, allocatable:: answer_negative(:,:,:,:,:,:)
13144  logical, allocatable:: check_negative(:,:,:,:,:,:)
13145  logical, allocatable:: both_negative(:,:,:,:,:,:)
13146 
13147 
13148  continue
13149  if (present(negative_support)) then
13150  negative_support_on = negative_support
13151  else
13152  negative_support_on = .true.
13153  end if
13154 
13155  err_flag = .false.
13156 
13157 
13158  answer_shape = shape(answer)
13159  check_shape = shape(check)
13160 
13161  consist_shape = answer_shape == check_shape
13162 
13163  if (.not. all(consist_shape)) then
13164  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13165  write(*,*) ''
13166  write(*,*) ' shape of check is (', check_shape, ')'
13167  write(*,*) ' is INCORRECT'
13168  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13169 
13170  call abortprogram('')
13171  end if
13172 
13173 
13174  allocate( mask_array( &
13175  & answer_shape(1), &
13176 
13177  & answer_shape(2), &
13178 
13179  & answer_shape(3), &
13180 
13181  & answer_shape(4), &
13182 
13183  & answer_shape(5), &
13184 
13185  & answer_shape(6) ) &
13186  & )
13187 
13188  allocate( judge( &
13189  & answer_shape(1), &
13190 
13191  & answer_shape(2), &
13192 
13193  & answer_shape(3), &
13194 
13195  & answer_shape(4), &
13196 
13197  & answer_shape(5), &
13198 
13199  & answer_shape(6) ) &
13200  & )
13201 
13202  allocate( judge_rev( &
13203  & answer_shape(1), &
13204 
13205  & answer_shape(2), &
13206 
13207  & answer_shape(3), &
13208 
13209  & answer_shape(4), &
13210 
13211  & answer_shape(5), &
13212 
13213  & answer_shape(6) ) &
13214  & )
13215 
13216  allocate( answer_negative( &
13217  & answer_shape(1), &
13218 
13219  & answer_shape(2), &
13220 
13221  & answer_shape(3), &
13222 
13223  & answer_shape(4), &
13224 
13225  & answer_shape(5), &
13226 
13227  & answer_shape(6) ) &
13228  & )
13229 
13230  allocate( check_negative( &
13231  & answer_shape(1), &
13232 
13233  & answer_shape(2), &
13234 
13235  & answer_shape(3), &
13236 
13237  & answer_shape(4), &
13238 
13239  & answer_shape(5), &
13240 
13241  & answer_shape(6) ) &
13242  & )
13243 
13244  allocate( both_negative( &
13245  & answer_shape(1), &
13246 
13247  & answer_shape(2), &
13248 
13249  & answer_shape(3), &
13250 
13251  & answer_shape(4), &
13252 
13253  & answer_shape(5), &
13254 
13255  & answer_shape(6) ) &
13256  & )
13257 
13258  answer_negative = answer < 0.0_dp
13259  check_negative = check < 0.0_dp
13260  both_negative = answer_negative .and. check_negative
13261  if (.not. negative_support_on) both_negative = .false.
13262 
13263  judge = answer < check
13264  where (both_negative) judge = .not. judge
13265 
13266  judge_rev = .not. judge
13267  err_flag = any(judge_rev)
13268  mask_array = 1
13269  pos = maxloc(mask_array, judge_rev)
13270 
13271  if (err_flag) then
13272 
13273  wrong = check( &
13274  & pos(1), &
13275 
13276  & pos(2), &
13277 
13278  & pos(3), &
13279 
13280  & pos(4), &
13281 
13282  & pos(5), &
13283 
13284  & pos(6) )
13285 
13286  right = answer( &
13287  & pos(1), &
13288 
13289  & pos(2), &
13290 
13291  & pos(3), &
13292 
13293  & pos(4), &
13294 
13295  & pos(5), &
13296 
13297  & pos(6) )
13298 
13299  write(unit=pos_array(1), fmt="(i20)") pos(1)
13300 
13301  write(unit=pos_array(2), fmt="(i20)") pos(2)
13302 
13303  write(unit=pos_array(3), fmt="(i20)") pos(3)
13304 
13305  write(unit=pos_array(4), fmt="(i20)") pos(4)
13306 
13307  write(unit=pos_array(5), fmt="(i20)") pos(5)
13308 
13309  write(unit=pos_array(6), fmt="(i20)") pos(6)
13310 
13311 
13312  pos_str = '(' // &
13313  & trim(adjustl(pos_array(1))) // ',' // &
13314 
13315  & trim(adjustl(pos_array(2))) // ',' // &
13316 
13317  & trim(adjustl(pos_array(3))) // ',' // &
13318 
13319  & trim(adjustl(pos_array(4))) // ',' // &
13320 
13321  & trim(adjustl(pos_array(5))) // ',' // &
13322 
13323  & trim(adjustl(pos_array(6))) // ')'
13324 
13325  if ( both_negative( &
13326  & pos(1), &
13327 
13328  & pos(2), &
13329 
13330  & pos(3), &
13331 
13332  & pos(4), &
13333 
13334  & pos(5), &
13335 
13336  & pos(6) ) ) then
13337 
13338  abs_mes = 'ABSOLUTE value of'
13339  else
13340  abs_mes = ''
13341 
13342  end if
13343 
13344  end if
13345  deallocate(mask_array, judge, judge_rev)
13346  deallocate(answer_negative, check_negative, both_negative)
13347 
13348 
13349 
13350 
13351  if (err_flag) then
13352  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13353  write(*,*) ''
13354  write(*,*) ' ' // trim(abs_mes) // &
13355  & ' check' // trim(pos_str) // ' = ', wrong
13356  write(*,*) ' is NOT GREATER THAN'
13357  write(*,*) ' ' // trim(abs_mes) // &
13358  & ' answer' // trim(pos_str) // ' = ', right
13359 
13360  call abortprogram('')
13361  else
13362  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13363  end if
13364 
13365 
13366  end subroutine dctestassertgreaterthandouble6
13367 
13368 
13369  subroutine dctestassertgreaterthandouble7( &
13370  & message, answer, check, negative_support)
13371  use sysdep, only: abortprogram
13372  use dc_types, only: string, token
13373  implicit none
13374  character(*), intent(in):: message
13375  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
13376  real(DP), intent(in):: check(:,:,:,:,:,:,:)
13377  logical, intent(in), optional:: negative_support
13378  logical:: err_flag
13379  logical:: negative_support_on
13380  character(STRING):: pos_str
13381  character(TOKEN):: abs_mes
13382  real(DP):: wrong, right
13383 
13384  integer:: answer_shape(7), check_shape(7), pos(7)
13385  logical:: consist_shape(7)
13386  character(TOKEN):: pos_array(7)
13387  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
13388  logical, allocatable:: judge(:,:,:,:,:,:,:)
13389  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
13390  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
13391  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
13392  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
13393 
13394 
13395  continue
13396  if (present(negative_support)) then
13397  negative_support_on = negative_support
13398  else
13399  negative_support_on = .true.
13400  end if
13401 
13402  err_flag = .false.
13403 
13404 
13405  answer_shape = shape(answer)
13406  check_shape = shape(check)
13407 
13408  consist_shape = answer_shape == check_shape
13409 
13410  if (.not. all(consist_shape)) then
13411  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13412  write(*,*) ''
13413  write(*,*) ' shape of check is (', check_shape, ')'
13414  write(*,*) ' is INCORRECT'
13415  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13416 
13417  call abortprogram('')
13418  end if
13419 
13420 
13421  allocate( mask_array( &
13422  & answer_shape(1), &
13423 
13424  & answer_shape(2), &
13425 
13426  & answer_shape(3), &
13427 
13428  & answer_shape(4), &
13429 
13430  & answer_shape(5), &
13431 
13432  & answer_shape(6), &
13433 
13434  & answer_shape(7) ) &
13435  & )
13436 
13437  allocate( judge( &
13438  & answer_shape(1), &
13439 
13440  & answer_shape(2), &
13441 
13442  & answer_shape(3), &
13443 
13444  & answer_shape(4), &
13445 
13446  & answer_shape(5), &
13447 
13448  & answer_shape(6), &
13449 
13450  & answer_shape(7) ) &
13451  & )
13452 
13453  allocate( judge_rev( &
13454  & answer_shape(1), &
13455 
13456  & answer_shape(2), &
13457 
13458  & answer_shape(3), &
13459 
13460  & answer_shape(4), &
13461 
13462  & answer_shape(5), &
13463 
13464  & answer_shape(6), &
13465 
13466  & answer_shape(7) ) &
13467  & )
13468 
13469  allocate( answer_negative( &
13470  & answer_shape(1), &
13471 
13472  & answer_shape(2), &
13473 
13474  & answer_shape(3), &
13475 
13476  & answer_shape(4), &
13477 
13478  & answer_shape(5), &
13479 
13480  & answer_shape(6), &
13481 
13482  & answer_shape(7) ) &
13483  & )
13484 
13485  allocate( check_negative( &
13486  & answer_shape(1), &
13487 
13488  & answer_shape(2), &
13489 
13490  & answer_shape(3), &
13491 
13492  & answer_shape(4), &
13493 
13494  & answer_shape(5), &
13495 
13496  & answer_shape(6), &
13497 
13498  & answer_shape(7) ) &
13499  & )
13500 
13501  allocate( both_negative( &
13502  & answer_shape(1), &
13503 
13504  & answer_shape(2), &
13505 
13506  & answer_shape(3), &
13507 
13508  & answer_shape(4), &
13509 
13510  & answer_shape(5), &
13511 
13512  & answer_shape(6), &
13513 
13514  & answer_shape(7) ) &
13515  & )
13516 
13517  answer_negative = answer < 0.0_dp
13518  check_negative = check < 0.0_dp
13519  both_negative = answer_negative .and. check_negative
13520  if (.not. negative_support_on) both_negative = .false.
13521 
13522  judge = answer < check
13523  where (both_negative) judge = .not. judge
13524 
13525  judge_rev = .not. judge
13526  err_flag = any(judge_rev)
13527  mask_array = 1
13528  pos = maxloc(mask_array, judge_rev)
13529 
13530  if (err_flag) then
13531 
13532  wrong = check( &
13533  & pos(1), &
13534 
13535  & pos(2), &
13536 
13537  & pos(3), &
13538 
13539  & pos(4), &
13540 
13541  & pos(5), &
13542 
13543  & pos(6), &
13544 
13545  & pos(7) )
13546 
13547  right = answer( &
13548  & pos(1), &
13549 
13550  & pos(2), &
13551 
13552  & pos(3), &
13553 
13554  & pos(4), &
13555 
13556  & pos(5), &
13557 
13558  & pos(6), &
13559 
13560  & pos(7) )
13561 
13562  write(unit=pos_array(1), fmt="(i20)") pos(1)
13563 
13564  write(unit=pos_array(2), fmt="(i20)") pos(2)
13565 
13566  write(unit=pos_array(3), fmt="(i20)") pos(3)
13567 
13568  write(unit=pos_array(4), fmt="(i20)") pos(4)
13569 
13570  write(unit=pos_array(5), fmt="(i20)") pos(5)
13571 
13572  write(unit=pos_array(6), fmt="(i20)") pos(6)
13573 
13574  write(unit=pos_array(7), fmt="(i20)") pos(7)
13575 
13576 
13577  pos_str = '(' // &
13578  & trim(adjustl(pos_array(1))) // ',' // &
13579 
13580  & trim(adjustl(pos_array(2))) // ',' // &
13581 
13582  & trim(adjustl(pos_array(3))) // ',' // &
13583 
13584  & trim(adjustl(pos_array(4))) // ',' // &
13585 
13586  & trim(adjustl(pos_array(5))) // ',' // &
13587 
13588  & trim(adjustl(pos_array(6))) // ',' // &
13589 
13590  & trim(adjustl(pos_array(7))) // ')'
13591 
13592  if ( both_negative( &
13593  & pos(1), &
13594 
13595  & pos(2), &
13596 
13597  & pos(3), &
13598 
13599  & pos(4), &
13600 
13601  & pos(5), &
13602 
13603  & pos(6), &
13604 
13605  & pos(7) ) ) then
13606 
13607  abs_mes = 'ABSOLUTE value of'
13608  else
13609  abs_mes = ''
13610 
13611  end if
13612 
13613  end if
13614  deallocate(mask_array, judge, judge_rev)
13615  deallocate(answer_negative, check_negative, both_negative)
13616 
13617 
13618 
13619 
13620  if (err_flag) then
13621  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13622  write(*,*) ''
13623  write(*,*) ' ' // trim(abs_mes) // &
13624  & ' check' // trim(pos_str) // ' = ', wrong
13625  write(*,*) ' is NOT GREATER THAN'
13626  write(*,*) ' ' // trim(abs_mes) // &
13627  & ' answer' // trim(pos_str) // ' = ', right
13628 
13629  call abortprogram('')
13630  else
13631  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13632  end if
13633 
13634 
13635  end subroutine dctestassertgreaterthandouble7
13636 
13637 
13638  subroutine dctestassertlessthanint0( &
13639  & message, answer, check, negative_support)
13640  use sysdep, only: abortprogram
13641  use dc_types, only: string, token
13642  implicit none
13643  character(*), intent(in):: message
13644  integer, intent(in):: answer
13645  integer, intent(in):: check
13646  logical, intent(in), optional:: negative_support
13647  logical:: err_flag
13648  logical:: negative_support_on
13649  character(STRING):: pos_str
13650  character(TOKEN):: abs_mes
13651  integer:: wrong, right
13652 
13653 
13654 
13655  continue
13656  if (present(negative_support)) then
13657  negative_support_on = negative_support
13658  else
13659  negative_support_on = .true.
13660  end if
13661 
13662  err_flag = .false.
13663 
13664 
13665 
13666 
13667  err_flag = .not. answer > check
13668  abs_mes = ''
13669 
13670  if ( answer < 0 &
13671  & .and. check < 0 &
13672  & .and. negative_support_on ) then
13673 
13674  err_flag = .not. err_flag
13675  abs_mes = 'ABSOLUTE value of'
13676  end if
13677 
13678  wrong = check
13679  right = answer
13680  pos_str = ''
13681 
13682 
13683 
13684 
13685  if (err_flag) then
13686  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13687  write(*,*) ''
13688  write(*,*) ' ' // trim(abs_mes) // &
13689  & ' check' // trim(pos_str) // ' = ', wrong
13690  write(*,*) ' is NOT LESS THAN'
13691  write(*,*) ' ' // trim(abs_mes) // &
13692  & ' answer' // trim(pos_str) // ' = ', right
13693 
13694  call abortprogram('')
13695  else
13696  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13697  end if
13698 
13699 
13700  end subroutine dctestassertlessthanint0
13701 
13702 
13703  subroutine dctestassertlessthanint1( &
13704  & message, answer, check, negative_support)
13705  use sysdep, only: abortprogram
13706  use dc_types, only: string, token
13707  implicit none
13708  character(*), intent(in):: message
13709  integer, intent(in):: answer(:)
13710  integer, intent(in):: check(:)
13711  logical, intent(in), optional:: negative_support
13712  logical:: err_flag
13713  logical:: negative_support_on
13714  character(STRING):: pos_str
13715  character(TOKEN):: abs_mes
13716  integer:: wrong, right
13717 
13718  integer:: answer_shape(1), check_shape(1), pos(1)
13719  logical:: consist_shape(1)
13720  character(TOKEN):: pos_array(1)
13721  integer, allocatable:: mask_array(:)
13722  logical, allocatable:: judge(:)
13723  logical, allocatable:: judge_rev(:)
13724  logical, allocatable:: answer_negative(:)
13725  logical, allocatable:: check_negative(:)
13726  logical, allocatable:: both_negative(:)
13727 
13728 
13729  continue
13730  if (present(negative_support)) then
13731  negative_support_on = negative_support
13732  else
13733  negative_support_on = .true.
13734  end if
13735 
13736  err_flag = .false.
13737 
13738 
13739  answer_shape = shape(answer)
13740  check_shape = shape(check)
13741 
13742  consist_shape = answer_shape == check_shape
13743 
13744  if (.not. all(consist_shape)) then
13745  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13746  write(*,*) ''
13747  write(*,*) ' shape of check is (', check_shape, ')'
13748  write(*,*) ' is INCORRECT'
13749  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13750 
13751  call abortprogram('')
13752  end if
13753 
13754 
13755  allocate( mask_array( &
13756 
13757  & answer_shape(1) ) &
13758  & )
13759 
13760  allocate( judge( &
13761 
13762  & answer_shape(1) ) &
13763  & )
13764 
13765  allocate( judge_rev( &
13766 
13767  & answer_shape(1) ) &
13768  & )
13769 
13770  allocate( answer_negative( &
13771 
13772  & answer_shape(1) ) &
13773  & )
13774 
13775  allocate( check_negative( &
13776 
13777  & answer_shape(1) ) &
13778  & )
13779 
13780  allocate( both_negative( &
13781 
13782  & answer_shape(1) ) &
13783  & )
13784 
13785  answer_negative = answer < 0
13786  check_negative = check < 0
13787  both_negative = answer_negative .and. check_negative
13788  if (.not. negative_support_on) both_negative = .false.
13789 
13790  judge = answer > check
13791  where (both_negative) judge = .not. judge
13792 
13793  judge_rev = .not. judge
13794  err_flag = any(judge_rev)
13795  mask_array = 1
13796  pos = maxloc(mask_array, judge_rev)
13797 
13798  if (err_flag) then
13799 
13800  wrong = check( &
13801 
13802  & pos(1) )
13803 
13804  right = answer( &
13805 
13806  & pos(1) )
13807 
13808  write(unit=pos_array(1), fmt="(i20)") pos(1)
13809 
13810 
13811  pos_str = '(' // &
13812 
13813  & trim(adjustl(pos_array(1))) // ')'
13814 
13815  if ( both_negative( &
13816 
13817  & pos(1) ) ) then
13818 
13819  abs_mes = 'ABSOLUTE value of'
13820  else
13821  abs_mes = ''
13822 
13823  end if
13824 
13825  end if
13826  deallocate(mask_array, judge, judge_rev)
13827  deallocate(answer_negative, check_negative, both_negative)
13828 
13829 
13830 
13831 
13832  if (err_flag) then
13833  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13834  write(*,*) ''
13835  write(*,*) ' ' // trim(abs_mes) // &
13836  & ' check' // trim(pos_str) // ' = ', wrong
13837  write(*,*) ' is NOT LESS THAN'
13838  write(*,*) ' ' // trim(abs_mes) // &
13839  & ' answer' // trim(pos_str) // ' = ', right
13840 
13841  call abortprogram('')
13842  else
13843  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13844  end if
13845 
13846 
13847  end subroutine dctestassertlessthanint1
13848 
13849 
13850  subroutine dctestassertlessthanint2( &
13851  & message, answer, check, negative_support)
13852  use sysdep, only: abortprogram
13853  use dc_types, only: string, token
13854  implicit none
13855  character(*), intent(in):: message
13856  integer, intent(in):: answer(:,:)
13857  integer, intent(in):: check(:,:)
13858  logical, intent(in), optional:: negative_support
13859  logical:: err_flag
13860  logical:: negative_support_on
13861  character(STRING):: pos_str
13862  character(TOKEN):: abs_mes
13863  integer:: wrong, right
13864 
13865  integer:: answer_shape(2), check_shape(2), pos(2)
13866  logical:: consist_shape(2)
13867  character(TOKEN):: pos_array(2)
13868  integer, allocatable:: mask_array(:,:)
13869  logical, allocatable:: judge(:,:)
13870  logical, allocatable:: judge_rev(:,:)
13871  logical, allocatable:: answer_negative(:,:)
13872  logical, allocatable:: check_negative(:,:)
13873  logical, allocatable:: both_negative(:,:)
13874 
13875 
13876  continue
13877  if (present(negative_support)) then
13878  negative_support_on = negative_support
13879  else
13880  negative_support_on = .true.
13881  end if
13882 
13883  err_flag = .false.
13884 
13885 
13886  answer_shape = shape(answer)
13887  check_shape = shape(check)
13888 
13889  consist_shape = answer_shape == check_shape
13890 
13891  if (.not. all(consist_shape)) then
13892  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13893  write(*,*) ''
13894  write(*,*) ' shape of check is (', check_shape, ')'
13895  write(*,*) ' is INCORRECT'
13896  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13897 
13898  call abortprogram('')
13899  end if
13900 
13901 
13902  allocate( mask_array( &
13903  & answer_shape(1), &
13904 
13905  & answer_shape(2) ) &
13906  & )
13907 
13908  allocate( judge( &
13909  & answer_shape(1), &
13910 
13911  & answer_shape(2) ) &
13912  & )
13913 
13914  allocate( judge_rev( &
13915  & answer_shape(1), &
13916 
13917  & answer_shape(2) ) &
13918  & )
13919 
13920  allocate( answer_negative( &
13921  & answer_shape(1), &
13922 
13923  & answer_shape(2) ) &
13924  & )
13925 
13926  allocate( check_negative( &
13927  & answer_shape(1), &
13928 
13929  & answer_shape(2) ) &
13930  & )
13931 
13932  allocate( both_negative( &
13933  & answer_shape(1), &
13934 
13935  & answer_shape(2) ) &
13936  & )
13937 
13938  answer_negative = answer < 0
13939  check_negative = check < 0
13940  both_negative = answer_negative .and. check_negative
13941  if (.not. negative_support_on) both_negative = .false.
13942 
13943  judge = answer > check
13944  where (both_negative) judge = .not. judge
13945 
13946  judge_rev = .not. judge
13947  err_flag = any(judge_rev)
13948  mask_array = 1
13949  pos = maxloc(mask_array, judge_rev)
13950 
13951  if (err_flag) then
13952 
13953  wrong = check( &
13954  & pos(1), &
13955 
13956  & pos(2) )
13957 
13958  right = answer( &
13959  & pos(1), &
13960 
13961  & pos(2) )
13962 
13963  write(unit=pos_array(1), fmt="(i20)") pos(1)
13964 
13965  write(unit=pos_array(2), fmt="(i20)") pos(2)
13966 
13967 
13968  pos_str = '(' // &
13969  & trim(adjustl(pos_array(1))) // ',' // &
13970 
13971  & trim(adjustl(pos_array(2))) // ')'
13972 
13973  if ( both_negative( &
13974  & pos(1), &
13975 
13976  & pos(2) ) ) then
13977 
13978  abs_mes = 'ABSOLUTE value of'
13979  else
13980  abs_mes = ''
13981 
13982  end if
13983 
13984  end if
13985  deallocate(mask_array, judge, judge_rev)
13986  deallocate(answer_negative, check_negative, both_negative)
13987 
13988 
13989 
13990 
13991  if (err_flag) then
13992  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13993  write(*,*) ''
13994  write(*,*) ' ' // trim(abs_mes) // &
13995  & ' check' // trim(pos_str) // ' = ', wrong
13996  write(*,*) ' is NOT LESS THAN'
13997  write(*,*) ' ' // trim(abs_mes) // &
13998  & ' answer' // trim(pos_str) // ' = ', right
13999 
14000  call abortprogram('')
14001  else
14002  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14003  end if
14004 
14005 
14006  end subroutine dctestassertlessthanint2
14007 
14008 
14009  subroutine dctestassertlessthanint3( &
14010  & message, answer, check, negative_support)
14011  use sysdep, only: abortprogram
14012  use dc_types, only: string, token
14013  implicit none
14014  character(*), intent(in):: message
14015  integer, intent(in):: answer(:,:,:)
14016  integer, intent(in):: check(:,:,:)
14017  logical, intent(in), optional:: negative_support
14018  logical:: err_flag
14019  logical:: negative_support_on
14020  character(STRING):: pos_str
14021  character(TOKEN):: abs_mes
14022  integer:: wrong, right
14023 
14024  integer:: answer_shape(3), check_shape(3), pos(3)
14025  logical:: consist_shape(3)
14026  character(TOKEN):: pos_array(3)
14027  integer, allocatable:: mask_array(:,:,:)
14028  logical, allocatable:: judge(:,:,:)
14029  logical, allocatable:: judge_rev(:,:,:)
14030  logical, allocatable:: answer_negative(:,:,:)
14031  logical, allocatable:: check_negative(:,:,:)
14032  logical, allocatable:: both_negative(:,:,:)
14033 
14034 
14035  continue
14036  if (present(negative_support)) then
14037  negative_support_on = negative_support
14038  else
14039  negative_support_on = .true.
14040  end if
14041 
14042  err_flag = .false.
14043 
14044 
14045  answer_shape = shape(answer)
14046  check_shape = shape(check)
14047 
14048  consist_shape = answer_shape == check_shape
14049 
14050  if (.not. all(consist_shape)) then
14051  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14052  write(*,*) ''
14053  write(*,*) ' shape of check is (', check_shape, ')'
14054  write(*,*) ' is INCORRECT'
14055  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14056 
14057  call abortprogram('')
14058  end if
14059 
14060 
14061  allocate( mask_array( &
14062  & answer_shape(1), &
14063 
14064  & answer_shape(2), &
14065 
14066  & answer_shape(3) ) &
14067  & )
14068 
14069  allocate( judge( &
14070  & answer_shape(1), &
14071 
14072  & answer_shape(2), &
14073 
14074  & answer_shape(3) ) &
14075  & )
14076 
14077  allocate( judge_rev( &
14078  & answer_shape(1), &
14079 
14080  & answer_shape(2), &
14081 
14082  & answer_shape(3) ) &
14083  & )
14084 
14085  allocate( answer_negative( &
14086  & answer_shape(1), &
14087 
14088  & answer_shape(2), &
14089 
14090  & answer_shape(3) ) &
14091  & )
14092 
14093  allocate( check_negative( &
14094  & answer_shape(1), &
14095 
14096  & answer_shape(2), &
14097 
14098  & answer_shape(3) ) &
14099  & )
14100 
14101  allocate( both_negative( &
14102  & answer_shape(1), &
14103 
14104  & answer_shape(2), &
14105 
14106  & answer_shape(3) ) &
14107  & )
14108 
14109  answer_negative = answer < 0
14110  check_negative = check < 0
14111  both_negative = answer_negative .and. check_negative
14112  if (.not. negative_support_on) both_negative = .false.
14113 
14114  judge = answer > check
14115  where (both_negative) judge = .not. judge
14116 
14117  judge_rev = .not. judge
14118  err_flag = any(judge_rev)
14119  mask_array = 1
14120  pos = maxloc(mask_array, judge_rev)
14121 
14122  if (err_flag) then
14123 
14124  wrong = check( &
14125  & pos(1), &
14126 
14127  & pos(2), &
14128 
14129  & pos(3) )
14130 
14131  right = answer( &
14132  & pos(1), &
14133 
14134  & pos(2), &
14135 
14136  & pos(3) )
14137 
14138  write(unit=pos_array(1), fmt="(i20)") pos(1)
14139 
14140  write(unit=pos_array(2), fmt="(i20)") pos(2)
14141 
14142  write(unit=pos_array(3), fmt="(i20)") pos(3)
14143 
14144 
14145  pos_str = '(' // &
14146  & trim(adjustl(pos_array(1))) // ',' // &
14147 
14148  & trim(adjustl(pos_array(2))) // ',' // &
14149 
14150  & trim(adjustl(pos_array(3))) // ')'
14151 
14152  if ( both_negative( &
14153  & pos(1), &
14154 
14155  & pos(2), &
14156 
14157  & pos(3) ) ) then
14158 
14159  abs_mes = 'ABSOLUTE value of'
14160  else
14161  abs_mes = ''
14162 
14163  end if
14164 
14165  end if
14166  deallocate(mask_array, judge, judge_rev)
14167  deallocate(answer_negative, check_negative, both_negative)
14168 
14169 
14170 
14171 
14172  if (err_flag) then
14173  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14174  write(*,*) ''
14175  write(*,*) ' ' // trim(abs_mes) // &
14176  & ' check' // trim(pos_str) // ' = ', wrong
14177  write(*,*) ' is NOT LESS THAN'
14178  write(*,*) ' ' // trim(abs_mes) // &
14179  & ' answer' // trim(pos_str) // ' = ', right
14180 
14181  call abortprogram('')
14182  else
14183  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14184  end if
14185 
14186 
14187  end subroutine dctestassertlessthanint3
14188 
14189 
14190  subroutine dctestassertlessthanint4( &
14191  & message, answer, check, negative_support)
14192  use sysdep, only: abortprogram
14193  use dc_types, only: string, token
14194  implicit none
14195  character(*), intent(in):: message
14196  integer, intent(in):: answer(:,:,:,:)
14197  integer, intent(in):: check(:,:,:,:)
14198  logical, intent(in), optional:: negative_support
14199  logical:: err_flag
14200  logical:: negative_support_on
14201  character(STRING):: pos_str
14202  character(TOKEN):: abs_mes
14203  integer:: wrong, right
14204 
14205  integer:: answer_shape(4), check_shape(4), pos(4)
14206  logical:: consist_shape(4)
14207  character(TOKEN):: pos_array(4)
14208  integer, allocatable:: mask_array(:,:,:,:)
14209  logical, allocatable:: judge(:,:,:,:)
14210  logical, allocatable:: judge_rev(:,:,:,:)
14211  logical, allocatable:: answer_negative(:,:,:,:)
14212  logical, allocatable:: check_negative(:,:,:,:)
14213  logical, allocatable:: both_negative(:,:,:,:)
14214 
14215 
14216  continue
14217  if (present(negative_support)) then
14218  negative_support_on = negative_support
14219  else
14220  negative_support_on = .true.
14221  end if
14222 
14223  err_flag = .false.
14224 
14225 
14226  answer_shape = shape(answer)
14227  check_shape = shape(check)
14228 
14229  consist_shape = answer_shape == check_shape
14230 
14231  if (.not. all(consist_shape)) then
14232  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14233  write(*,*) ''
14234  write(*,*) ' shape of check is (', check_shape, ')'
14235  write(*,*) ' is INCORRECT'
14236  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14237 
14238  call abortprogram('')
14239  end if
14240 
14241 
14242  allocate( mask_array( &
14243  & answer_shape(1), &
14244 
14245  & answer_shape(2), &
14246 
14247  & answer_shape(3), &
14248 
14249  & answer_shape(4) ) &
14250  & )
14251 
14252  allocate( judge( &
14253  & answer_shape(1), &
14254 
14255  & answer_shape(2), &
14256 
14257  & answer_shape(3), &
14258 
14259  & answer_shape(4) ) &
14260  & )
14261 
14262  allocate( judge_rev( &
14263  & answer_shape(1), &
14264 
14265  & answer_shape(2), &
14266 
14267  & answer_shape(3), &
14268 
14269  & answer_shape(4) ) &
14270  & )
14271 
14272  allocate( answer_negative( &
14273  & answer_shape(1), &
14274 
14275  & answer_shape(2), &
14276 
14277  & answer_shape(3), &
14278 
14279  & answer_shape(4) ) &
14280  & )
14281 
14282  allocate( check_negative( &
14283  & answer_shape(1), &
14284 
14285  & answer_shape(2), &
14286 
14287  & answer_shape(3), &
14288 
14289  & answer_shape(4) ) &
14290  & )
14291 
14292  allocate( both_negative( &
14293  & answer_shape(1), &
14294 
14295  & answer_shape(2), &
14296 
14297  & answer_shape(3), &
14298 
14299  & answer_shape(4) ) &
14300  & )
14301 
14302  answer_negative = answer < 0
14303  check_negative = check < 0
14304  both_negative = answer_negative .and. check_negative
14305  if (.not. negative_support_on) both_negative = .false.
14306 
14307  judge = answer > check
14308  where (both_negative) judge = .not. judge
14309 
14310  judge_rev = .not. judge
14311  err_flag = any(judge_rev)
14312  mask_array = 1
14313  pos = maxloc(mask_array, judge_rev)
14314 
14315  if (err_flag) then
14316 
14317  wrong = check( &
14318  & pos(1), &
14319 
14320  & pos(2), &
14321 
14322  & pos(3), &
14323 
14324  & pos(4) )
14325 
14326  right = answer( &
14327  & pos(1), &
14328 
14329  & pos(2), &
14330 
14331  & pos(3), &
14332 
14333  & pos(4) )
14334 
14335  write(unit=pos_array(1), fmt="(i20)") pos(1)
14336 
14337  write(unit=pos_array(2), fmt="(i20)") pos(2)
14338 
14339  write(unit=pos_array(3), fmt="(i20)") pos(3)
14340 
14341  write(unit=pos_array(4), fmt="(i20)") pos(4)
14342 
14343 
14344  pos_str = '(' // &
14345  & trim(adjustl(pos_array(1))) // ',' // &
14346 
14347  & trim(adjustl(pos_array(2))) // ',' // &
14348 
14349  & trim(adjustl(pos_array(3))) // ',' // &
14350 
14351  & trim(adjustl(pos_array(4))) // ')'
14352 
14353  if ( both_negative( &
14354  & pos(1), &
14355 
14356  & pos(2), &
14357 
14358  & pos(3), &
14359 
14360  & pos(4) ) ) then
14361 
14362  abs_mes = 'ABSOLUTE value of'
14363  else
14364  abs_mes = ''
14365 
14366  end if
14367 
14368  end if
14369  deallocate(mask_array, judge, judge_rev)
14370  deallocate(answer_negative, check_negative, both_negative)
14371 
14372 
14373 
14374 
14375  if (err_flag) then
14376  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14377  write(*,*) ''
14378  write(*,*) ' ' // trim(abs_mes) // &
14379  & ' check' // trim(pos_str) // ' = ', wrong
14380  write(*,*) ' is NOT LESS THAN'
14381  write(*,*) ' ' // trim(abs_mes) // &
14382  & ' answer' // trim(pos_str) // ' = ', right
14383 
14384  call abortprogram('')
14385  else
14386  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14387  end if
14388 
14389 
14390  end subroutine dctestassertlessthanint4
14391 
14392 
14393  subroutine dctestassertlessthanint5( &
14394  & message, answer, check, negative_support)
14395  use sysdep, only: abortprogram
14396  use dc_types, only: string, token
14397  implicit none
14398  character(*), intent(in):: message
14399  integer, intent(in):: answer(:,:,:,:,:)
14400  integer, intent(in):: check(:,:,:,:,:)
14401  logical, intent(in), optional:: negative_support
14402  logical:: err_flag
14403  logical:: negative_support_on
14404  character(STRING):: pos_str
14405  character(TOKEN):: abs_mes
14406  integer:: wrong, right
14407 
14408  integer:: answer_shape(5), check_shape(5), pos(5)
14409  logical:: consist_shape(5)
14410  character(TOKEN):: pos_array(5)
14411  integer, allocatable:: mask_array(:,:,:,:,:)
14412  logical, allocatable:: judge(:,:,:,:,:)
14413  logical, allocatable:: judge_rev(:,:,:,:,:)
14414  logical, allocatable:: answer_negative(:,:,:,:,:)
14415  logical, allocatable:: check_negative(:,:,:,:,:)
14416  logical, allocatable:: both_negative(:,:,:,:,:)
14417 
14418 
14419  continue
14420  if (present(negative_support)) then
14421  negative_support_on = negative_support
14422  else
14423  negative_support_on = .true.
14424  end if
14425 
14426  err_flag = .false.
14427 
14428 
14429  answer_shape = shape(answer)
14430  check_shape = shape(check)
14431 
14432  consist_shape = answer_shape == check_shape
14433 
14434  if (.not. all(consist_shape)) then
14435  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14436  write(*,*) ''
14437  write(*,*) ' shape of check is (', check_shape, ')'
14438  write(*,*) ' is INCORRECT'
14439  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14440 
14441  call abortprogram('')
14442  end if
14443 
14444 
14445  allocate( mask_array( &
14446  & answer_shape(1), &
14447 
14448  & answer_shape(2), &
14449 
14450  & answer_shape(3), &
14451 
14452  & answer_shape(4), &
14453 
14454  & answer_shape(5) ) &
14455  & )
14456 
14457  allocate( judge( &
14458  & answer_shape(1), &
14459 
14460  & answer_shape(2), &
14461 
14462  & answer_shape(3), &
14463 
14464  & answer_shape(4), &
14465 
14466  & answer_shape(5) ) &
14467  & )
14468 
14469  allocate( judge_rev( &
14470  & answer_shape(1), &
14471 
14472  & answer_shape(2), &
14473 
14474  & answer_shape(3), &
14475 
14476  & answer_shape(4), &
14477 
14478  & answer_shape(5) ) &
14479  & )
14480 
14481  allocate( answer_negative( &
14482  & answer_shape(1), &
14483 
14484  & answer_shape(2), &
14485 
14486  & answer_shape(3), &
14487 
14488  & answer_shape(4), &
14489 
14490  & answer_shape(5) ) &
14491  & )
14492 
14493  allocate( check_negative( &
14494  & answer_shape(1), &
14495 
14496  & answer_shape(2), &
14497 
14498  & answer_shape(3), &
14499 
14500  & answer_shape(4), &
14501 
14502  & answer_shape(5) ) &
14503  & )
14504 
14505  allocate( both_negative( &
14506  & answer_shape(1), &
14507 
14508  & answer_shape(2), &
14509 
14510  & answer_shape(3), &
14511 
14512  & answer_shape(4), &
14513 
14514  & answer_shape(5) ) &
14515  & )
14516 
14517  answer_negative = answer < 0
14518  check_negative = check < 0
14519  both_negative = answer_negative .and. check_negative
14520  if (.not. negative_support_on) both_negative = .false.
14521 
14522  judge = answer > check
14523  where (both_negative) judge = .not. judge
14524 
14525  judge_rev = .not. judge
14526  err_flag = any(judge_rev)
14527  mask_array = 1
14528  pos = maxloc(mask_array, judge_rev)
14529 
14530  if (err_flag) then
14531 
14532  wrong = check( &
14533  & pos(1), &
14534 
14535  & pos(2), &
14536 
14537  & pos(3), &
14538 
14539  & pos(4), &
14540 
14541  & pos(5) )
14542 
14543  right = answer( &
14544  & pos(1), &
14545 
14546  & pos(2), &
14547 
14548  & pos(3), &
14549 
14550  & pos(4), &
14551 
14552  & pos(5) )
14553 
14554  write(unit=pos_array(1), fmt="(i20)") pos(1)
14555 
14556  write(unit=pos_array(2), fmt="(i20)") pos(2)
14557 
14558  write(unit=pos_array(3), fmt="(i20)") pos(3)
14559 
14560  write(unit=pos_array(4), fmt="(i20)") pos(4)
14561 
14562  write(unit=pos_array(5), fmt="(i20)") pos(5)
14563 
14564 
14565  pos_str = '(' // &
14566  & trim(adjustl(pos_array(1))) // ',' // &
14567 
14568  & trim(adjustl(pos_array(2))) // ',' // &
14569 
14570  & trim(adjustl(pos_array(3))) // ',' // &
14571 
14572  & trim(adjustl(pos_array(4))) // ',' // &
14573 
14574  & trim(adjustl(pos_array(5))) // ')'
14575 
14576  if ( both_negative( &
14577  & pos(1), &
14578 
14579  & pos(2), &
14580 
14581  & pos(3), &
14582 
14583  & pos(4), &
14584 
14585  & pos(5) ) ) then
14586 
14587  abs_mes = 'ABSOLUTE value of'
14588  else
14589  abs_mes = ''
14590 
14591  end if
14592 
14593  end if
14594  deallocate(mask_array, judge, judge_rev)
14595  deallocate(answer_negative, check_negative, both_negative)
14596 
14597 
14598 
14599 
14600  if (err_flag) then
14601  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14602  write(*,*) ''
14603  write(*,*) ' ' // trim(abs_mes) // &
14604  & ' check' // trim(pos_str) // ' = ', wrong
14605  write(*,*) ' is NOT LESS THAN'
14606  write(*,*) ' ' // trim(abs_mes) // &
14607  & ' answer' // trim(pos_str) // ' = ', right
14608 
14609  call abortprogram('')
14610  else
14611  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14612  end if
14613 
14614 
14615  end subroutine dctestassertlessthanint5
14616 
14617 
14618  subroutine dctestassertlessthanint6( &
14619  & message, answer, check, negative_support)
14620  use sysdep, only: abortprogram
14621  use dc_types, only: string, token
14622  implicit none
14623  character(*), intent(in):: message
14624  integer, intent(in):: answer(:,:,:,:,:,:)
14625  integer, intent(in):: check(:,:,:,:,:,:)
14626  logical, intent(in), optional:: negative_support
14627  logical:: err_flag
14628  logical:: negative_support_on
14629  character(STRING):: pos_str
14630  character(TOKEN):: abs_mes
14631  integer:: wrong, right
14632 
14633  integer:: answer_shape(6), check_shape(6), pos(6)
14634  logical:: consist_shape(6)
14635  character(TOKEN):: pos_array(6)
14636  integer, allocatable:: mask_array(:,:,:,:,:,:)
14637  logical, allocatable:: judge(:,:,:,:,:,:)
14638  logical, allocatable:: judge_rev(:,:,:,:,:,:)
14639  logical, allocatable:: answer_negative(:,:,:,:,:,:)
14640  logical, allocatable:: check_negative(:,:,:,:,:,:)
14641  logical, allocatable:: both_negative(:,:,:,:,:,:)
14642 
14643 
14644  continue
14645  if (present(negative_support)) then
14646  negative_support_on = negative_support
14647  else
14648  negative_support_on = .true.
14649  end if
14650 
14651  err_flag = .false.
14652 
14653 
14654  answer_shape = shape(answer)
14655  check_shape = shape(check)
14656 
14657  consist_shape = answer_shape == check_shape
14658 
14659  if (.not. all(consist_shape)) then
14660  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14661  write(*,*) ''
14662  write(*,*) ' shape of check is (', check_shape, ')'
14663  write(*,*) ' is INCORRECT'
14664  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14665 
14666  call abortprogram('')
14667  end if
14668 
14669 
14670  allocate( mask_array( &
14671  & answer_shape(1), &
14672 
14673  & answer_shape(2), &
14674 
14675  & answer_shape(3), &
14676 
14677  & answer_shape(4), &
14678 
14679  & answer_shape(5), &
14680 
14681  & answer_shape(6) ) &
14682  & )
14683 
14684  allocate( judge( &
14685  & answer_shape(1), &
14686 
14687  & answer_shape(2), &
14688 
14689  & answer_shape(3), &
14690 
14691  & answer_shape(4), &
14692 
14693  & answer_shape(5), &
14694 
14695  & answer_shape(6) ) &
14696  & )
14697 
14698  allocate( judge_rev( &
14699  & answer_shape(1), &
14700 
14701  & answer_shape(2), &
14702 
14703  & answer_shape(3), &
14704 
14705  & answer_shape(4), &
14706 
14707  & answer_shape(5), &
14708 
14709  & answer_shape(6) ) &
14710  & )
14711 
14712  allocate( answer_negative( &
14713  & answer_shape(1), &
14714 
14715  & answer_shape(2), &
14716 
14717  & answer_shape(3), &
14718 
14719  & answer_shape(4), &
14720 
14721  & answer_shape(5), &
14722 
14723  & answer_shape(6) ) &
14724  & )
14725 
14726  allocate( check_negative( &
14727  & answer_shape(1), &
14728 
14729  & answer_shape(2), &
14730 
14731  & answer_shape(3), &
14732 
14733  & answer_shape(4), &
14734 
14735  & answer_shape(5), &
14736 
14737  & answer_shape(6) ) &
14738  & )
14739 
14740  allocate( both_negative( &
14741  & answer_shape(1), &
14742 
14743  & answer_shape(2), &
14744 
14745  & answer_shape(3), &
14746 
14747  & answer_shape(4), &
14748 
14749  & answer_shape(5), &
14750 
14751  & answer_shape(6) ) &
14752  & )
14753 
14754  answer_negative = answer < 0
14755  check_negative = check < 0
14756  both_negative = answer_negative .and. check_negative
14757  if (.not. negative_support_on) both_negative = .false.
14758 
14759  judge = answer > check
14760  where (both_negative) judge = .not. judge
14761 
14762  judge_rev = .not. judge
14763  err_flag = any(judge_rev)
14764  mask_array = 1
14765  pos = maxloc(mask_array, judge_rev)
14766 
14767  if (err_flag) then
14768 
14769  wrong = check( &
14770  & pos(1), &
14771 
14772  & pos(2), &
14773 
14774  & pos(3), &
14775 
14776  & pos(4), &
14777 
14778  & pos(5), &
14779 
14780  & pos(6) )
14781 
14782  right = answer( &
14783  & pos(1), &
14784 
14785  & pos(2), &
14786 
14787  & pos(3), &
14788 
14789  & pos(4), &
14790 
14791  & pos(5), &
14792 
14793  & pos(6) )
14794 
14795  write(unit=pos_array(1), fmt="(i20)") pos(1)
14796 
14797  write(unit=pos_array(2), fmt="(i20)") pos(2)
14798 
14799  write(unit=pos_array(3), fmt="(i20)") pos(3)
14800 
14801  write(unit=pos_array(4), fmt="(i20)") pos(4)
14802 
14803  write(unit=pos_array(5), fmt="(i20)") pos(5)
14804 
14805  write(unit=pos_array(6), fmt="(i20)") pos(6)
14806 
14807 
14808  pos_str = '(' // &
14809  & trim(adjustl(pos_array(1))) // ',' // &
14810 
14811  & trim(adjustl(pos_array(2))) // ',' // &
14812 
14813  & trim(adjustl(pos_array(3))) // ',' // &
14814 
14815  & trim(adjustl(pos_array(4))) // ',' // &
14816 
14817  & trim(adjustl(pos_array(5))) // ',' // &
14818 
14819  & trim(adjustl(pos_array(6))) // ')'
14820 
14821  if ( both_negative( &
14822  & pos(1), &
14823 
14824  & pos(2), &
14825 
14826  & pos(3), &
14827 
14828  & pos(4), &
14829 
14830  & pos(5), &
14831 
14832  & pos(6) ) ) then
14833 
14834  abs_mes = 'ABSOLUTE value of'
14835  else
14836  abs_mes = ''
14837 
14838  end if
14839 
14840  end if
14841  deallocate(mask_array, judge, judge_rev)
14842  deallocate(answer_negative, check_negative, both_negative)
14843 
14844 
14845 
14846 
14847  if (err_flag) then
14848  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14849  write(*,*) ''
14850  write(*,*) ' ' // trim(abs_mes) // &
14851  & ' check' // trim(pos_str) // ' = ', wrong
14852  write(*,*) ' is NOT LESS THAN'
14853  write(*,*) ' ' // trim(abs_mes) // &
14854  & ' answer' // trim(pos_str) // ' = ', right
14855 
14856  call abortprogram('')
14857  else
14858  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14859  end if
14860 
14861 
14862  end subroutine dctestassertlessthanint6
14863 
14864 
14865  subroutine dctestassertlessthanint7( &
14866  & message, answer, check, negative_support)
14867  use sysdep, only: abortprogram
14868  use dc_types, only: string, token
14869  implicit none
14870  character(*), intent(in):: message
14871  integer, intent(in):: answer(:,:,:,:,:,:,:)
14872  integer, intent(in):: check(:,:,:,:,:,:,:)
14873  logical, intent(in), optional:: negative_support
14874  logical:: err_flag
14875  logical:: negative_support_on
14876  character(STRING):: pos_str
14877  character(TOKEN):: abs_mes
14878  integer:: wrong, right
14879 
14880  integer:: answer_shape(7), check_shape(7), pos(7)
14881  logical:: consist_shape(7)
14882  character(TOKEN):: pos_array(7)
14883  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
14884  logical, allocatable:: judge(:,:,:,:,:,:,:)
14885  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
14886  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
14887  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
14888  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
14889 
14890 
14891  continue
14892  if (present(negative_support)) then
14893  negative_support_on = negative_support
14894  else
14895  negative_support_on = .true.
14896  end if
14897 
14898  err_flag = .false.
14899 
14900 
14901  answer_shape = shape(answer)
14902  check_shape = shape(check)
14903 
14904  consist_shape = answer_shape == check_shape
14905 
14906  if (.not. all(consist_shape)) then
14907  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14908  write(*,*) ''
14909  write(*,*) ' shape of check is (', check_shape, ')'
14910  write(*,*) ' is INCORRECT'
14911  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14912 
14913  call abortprogram('')
14914  end if
14915 
14916 
14917  allocate( mask_array( &
14918  & answer_shape(1), &
14919 
14920  & answer_shape(2), &
14921 
14922  & answer_shape(3), &
14923 
14924  & answer_shape(4), &
14925 
14926  & answer_shape(5), &
14927 
14928  & answer_shape(6), &
14929 
14930  & answer_shape(7) ) &
14931  & )
14932 
14933  allocate( judge( &
14934  & answer_shape(1), &
14935 
14936  & answer_shape(2), &
14937 
14938  & answer_shape(3), &
14939 
14940  & answer_shape(4), &
14941 
14942  & answer_shape(5), &
14943 
14944  & answer_shape(6), &
14945 
14946  & answer_shape(7) ) &
14947  & )
14948 
14949  allocate( judge_rev( &
14950  & answer_shape(1), &
14951 
14952  & answer_shape(2), &
14953 
14954  & answer_shape(3), &
14955 
14956  & answer_shape(4), &
14957 
14958  & answer_shape(5), &
14959 
14960  & answer_shape(6), &
14961 
14962  & answer_shape(7) ) &
14963  & )
14964 
14965  allocate( answer_negative( &
14966  & answer_shape(1), &
14967 
14968  & answer_shape(2), &
14969 
14970  & answer_shape(3), &
14971 
14972  & answer_shape(4), &
14973 
14974  & answer_shape(5), &
14975 
14976  & answer_shape(6), &
14977 
14978  & answer_shape(7) ) &
14979  & )
14980 
14981  allocate( check_negative( &
14982  & answer_shape(1), &
14983 
14984  & answer_shape(2), &
14985 
14986  & answer_shape(3), &
14987 
14988  & answer_shape(4), &
14989 
14990  & answer_shape(5), &
14991 
14992  & answer_shape(6), &
14993 
14994  & answer_shape(7) ) &
14995  & )
14996 
14997  allocate( both_negative( &
14998  & answer_shape(1), &
14999 
15000  & answer_shape(2), &
15001 
15002  & answer_shape(3), &
15003 
15004  & answer_shape(4), &
15005 
15006  & answer_shape(5), &
15007 
15008  & answer_shape(6), &
15009 
15010  & answer_shape(7) ) &
15011  & )
15012 
15013  answer_negative = answer < 0
15014  check_negative = check < 0
15015  both_negative = answer_negative .and. check_negative
15016  if (.not. negative_support_on) both_negative = .false.
15017 
15018  judge = answer > check
15019  where (both_negative) judge = .not. judge
15020 
15021  judge_rev = .not. judge
15022  err_flag = any(judge_rev)
15023  mask_array = 1
15024  pos = maxloc(mask_array, judge_rev)
15025 
15026  if (err_flag) then
15027 
15028  wrong = check( &
15029  & pos(1), &
15030 
15031  & pos(2), &
15032 
15033  & pos(3), &
15034 
15035  & pos(4), &
15036 
15037  & pos(5), &
15038 
15039  & pos(6), &
15040 
15041  & pos(7) )
15042 
15043  right = answer( &
15044  & pos(1), &
15045 
15046  & pos(2), &
15047 
15048  & pos(3), &
15049 
15050  & pos(4), &
15051 
15052  & pos(5), &
15053 
15054  & pos(6), &
15055 
15056  & pos(7) )
15057 
15058  write(unit=pos_array(1), fmt="(i20)") pos(1)
15059 
15060  write(unit=pos_array(2), fmt="(i20)") pos(2)
15061 
15062  write(unit=pos_array(3), fmt="(i20)") pos(3)
15063 
15064  write(unit=pos_array(4), fmt="(i20)") pos(4)
15065 
15066  write(unit=pos_array(5), fmt="(i20)") pos(5)
15067 
15068  write(unit=pos_array(6), fmt="(i20)") pos(6)
15069 
15070  write(unit=pos_array(7), fmt="(i20)") pos(7)
15071 
15072 
15073  pos_str = '(' // &
15074  & trim(adjustl(pos_array(1))) // ',' // &
15075 
15076  & trim(adjustl(pos_array(2))) // ',' // &
15077 
15078  & trim(adjustl(pos_array(3))) // ',' // &
15079 
15080  & trim(adjustl(pos_array(4))) // ',' // &
15081 
15082  & trim(adjustl(pos_array(5))) // ',' // &
15083 
15084  & trim(adjustl(pos_array(6))) // ',' // &
15085 
15086  & trim(adjustl(pos_array(7))) // ')'
15087 
15088  if ( both_negative( &
15089  & pos(1), &
15090 
15091  & pos(2), &
15092 
15093  & pos(3), &
15094 
15095  & pos(4), &
15096 
15097  & pos(5), &
15098 
15099  & pos(6), &
15100 
15101  & pos(7) ) ) then
15102 
15103  abs_mes = 'ABSOLUTE value of'
15104  else
15105  abs_mes = ''
15106 
15107  end if
15108 
15109  end if
15110  deallocate(mask_array, judge, judge_rev)
15111  deallocate(answer_negative, check_negative, both_negative)
15112 
15113 
15114 
15115 
15116  if (err_flag) then
15117  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15118  write(*,*) ''
15119  write(*,*) ' ' // trim(abs_mes) // &
15120  & ' check' // trim(pos_str) // ' = ', wrong
15121  write(*,*) ' is NOT LESS THAN'
15122  write(*,*) ' ' // trim(abs_mes) // &
15123  & ' answer' // trim(pos_str) // ' = ', right
15124 
15125  call abortprogram('')
15126  else
15127  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15128  end if
15129 
15130 
15131  end subroutine dctestassertlessthanint7
15132 
15133 
15134  subroutine dctestassertlessthanreal0( &
15135  & message, answer, check, negative_support)
15136  use sysdep, only: abortprogram
15137  use dc_types, only: string, token
15138  implicit none
15139  character(*), intent(in):: message
15140  real, intent(in):: answer
15141  real, intent(in):: check
15142  logical, intent(in), optional:: negative_support
15143  logical:: err_flag
15144  logical:: negative_support_on
15145  character(STRING):: pos_str
15146  character(TOKEN):: abs_mes
15147  real:: wrong, right
15148 
15149 
15150 
15151  continue
15152  if (present(negative_support)) then
15153  negative_support_on = negative_support
15154  else
15155  negative_support_on = .true.
15156  end if
15157 
15158  err_flag = .false.
15159 
15160 
15161 
15162 
15163  err_flag = .not. answer > check
15164  abs_mes = ''
15165 
15166  if ( answer < 0.0 &
15167  & .and. check < 0.0 &
15168  & .and. negative_support_on ) then
15169 
15170  err_flag = .not. err_flag
15171  abs_mes = 'ABSOLUTE value of'
15172  end if
15173 
15174  wrong = check
15175  right = answer
15176  pos_str = ''
15177 
15178 
15179 
15180 
15181  if (err_flag) then
15182  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15183  write(*,*) ''
15184  write(*,*) ' ' // trim(abs_mes) // &
15185  & ' check' // trim(pos_str) // ' = ', wrong
15186  write(*,*) ' is NOT LESS THAN'
15187  write(*,*) ' ' // trim(abs_mes) // &
15188  & ' answer' // trim(pos_str) // ' = ', right
15189 
15190  call abortprogram('')
15191  else
15192  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15193  end if
15194 
15195 
15196  end subroutine dctestassertlessthanreal0
15197 
15198 
15199  subroutine dctestassertlessthanreal1( &
15200  & message, answer, check, negative_support)
15201  use sysdep, only: abortprogram
15202  use dc_types, only: string, token
15203  implicit none
15204  character(*), intent(in):: message
15205  real, intent(in):: answer(:)
15206  real, intent(in):: check(:)
15207  logical, intent(in), optional:: negative_support
15208  logical:: err_flag
15209  logical:: negative_support_on
15210  character(STRING):: pos_str
15211  character(TOKEN):: abs_mes
15212  real:: wrong, right
15213 
15214  integer:: answer_shape(1), check_shape(1), pos(1)
15215  logical:: consist_shape(1)
15216  character(TOKEN):: pos_array(1)
15217  integer, allocatable:: mask_array(:)
15218  logical, allocatable:: judge(:)
15219  logical, allocatable:: judge_rev(:)
15220  logical, allocatable:: answer_negative(:)
15221  logical, allocatable:: check_negative(:)
15222  logical, allocatable:: both_negative(:)
15223 
15224 
15225  continue
15226  if (present(negative_support)) then
15227  negative_support_on = negative_support
15228  else
15229  negative_support_on = .true.
15230  end if
15231 
15232  err_flag = .false.
15233 
15234 
15235  answer_shape = shape(answer)
15236  check_shape = shape(check)
15237 
15238  consist_shape = answer_shape == check_shape
15239 
15240  if (.not. all(consist_shape)) then
15241  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15242  write(*,*) ''
15243  write(*,*) ' shape of check is (', check_shape, ')'
15244  write(*,*) ' is INCORRECT'
15245  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15246 
15247  call abortprogram('')
15248  end if
15249 
15250 
15251  allocate( mask_array( &
15252 
15253  & answer_shape(1) ) &
15254  & )
15255 
15256  allocate( judge( &
15257 
15258  & answer_shape(1) ) &
15259  & )
15260 
15261  allocate( judge_rev( &
15262 
15263  & answer_shape(1) ) &
15264  & )
15265 
15266  allocate( answer_negative( &
15267 
15268  & answer_shape(1) ) &
15269  & )
15270 
15271  allocate( check_negative( &
15272 
15273  & answer_shape(1) ) &
15274  & )
15275 
15276  allocate( both_negative( &
15277 
15278  & answer_shape(1) ) &
15279  & )
15280 
15281  answer_negative = answer < 0.0
15282  check_negative = check < 0.0
15283  both_negative = answer_negative .and. check_negative
15284  if (.not. negative_support_on) both_negative = .false.
15285 
15286  judge = answer > check
15287  where (both_negative) judge = .not. judge
15288 
15289  judge_rev = .not. judge
15290  err_flag = any(judge_rev)
15291  mask_array = 1
15292  pos = maxloc(mask_array, judge_rev)
15293 
15294  if (err_flag) then
15295 
15296  wrong = check( &
15297 
15298  & pos(1) )
15299 
15300  right = answer( &
15301 
15302  & pos(1) )
15303 
15304  write(unit=pos_array(1), fmt="(i20)") pos(1)
15305 
15306 
15307  pos_str = '(' // &
15308 
15309  & trim(adjustl(pos_array(1))) // ')'
15310 
15311  if ( both_negative( &
15312 
15313  & pos(1) ) ) then
15314 
15315  abs_mes = 'ABSOLUTE value of'
15316  else
15317  abs_mes = ''
15318 
15319  end if
15320 
15321  end if
15322  deallocate(mask_array, judge, judge_rev)
15323  deallocate(answer_negative, check_negative, both_negative)
15324 
15325 
15326 
15327 
15328  if (err_flag) then
15329  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15330  write(*,*) ''
15331  write(*,*) ' ' // trim(abs_mes) // &
15332  & ' check' // trim(pos_str) // ' = ', wrong
15333  write(*,*) ' is NOT LESS THAN'
15334  write(*,*) ' ' // trim(abs_mes) // &
15335  & ' answer' // trim(pos_str) // ' = ', right
15336 
15337  call abortprogram('')
15338  else
15339  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15340  end if
15341 
15342 
15343  end subroutine dctestassertlessthanreal1
15344 
15345 
15346  subroutine dctestassertlessthanreal2( &
15347  & message, answer, check, negative_support)
15348  use sysdep, only: abortprogram
15349  use dc_types, only: string, token
15350  implicit none
15351  character(*), intent(in):: message
15352  real, intent(in):: answer(:,:)
15353  real, intent(in):: check(:,:)
15354  logical, intent(in), optional:: negative_support
15355  logical:: err_flag
15356  logical:: negative_support_on
15357  character(STRING):: pos_str
15358  character(TOKEN):: abs_mes
15359  real:: wrong, right
15360 
15361  integer:: answer_shape(2), check_shape(2), pos(2)
15362  logical:: consist_shape(2)
15363  character(TOKEN):: pos_array(2)
15364  integer, allocatable:: mask_array(:,:)
15365  logical, allocatable:: judge(:,:)
15366  logical, allocatable:: judge_rev(:,:)
15367  logical, allocatable:: answer_negative(:,:)
15368  logical, allocatable:: check_negative(:,:)
15369  logical, allocatable:: both_negative(:,:)
15370 
15371 
15372  continue
15373  if (present(negative_support)) then
15374  negative_support_on = negative_support
15375  else
15376  negative_support_on = .true.
15377  end if
15378 
15379  err_flag = .false.
15380 
15381 
15382  answer_shape = shape(answer)
15383  check_shape = shape(check)
15384 
15385  consist_shape = answer_shape == check_shape
15386 
15387  if (.not. all(consist_shape)) then
15388  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15389  write(*,*) ''
15390  write(*,*) ' shape of check is (', check_shape, ')'
15391  write(*,*) ' is INCORRECT'
15392  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15393 
15394  call abortprogram('')
15395  end if
15396 
15397 
15398  allocate( mask_array( &
15399  & answer_shape(1), &
15400 
15401  & answer_shape(2) ) &
15402  & )
15403 
15404  allocate( judge( &
15405  & answer_shape(1), &
15406 
15407  & answer_shape(2) ) &
15408  & )
15409 
15410  allocate( judge_rev( &
15411  & answer_shape(1), &
15412 
15413  & answer_shape(2) ) &
15414  & )
15415 
15416  allocate( answer_negative( &
15417  & answer_shape(1), &
15418 
15419  & answer_shape(2) ) &
15420  & )
15421 
15422  allocate( check_negative( &
15423  & answer_shape(1), &
15424 
15425  & answer_shape(2) ) &
15426  & )
15427 
15428  allocate( both_negative( &
15429  & answer_shape(1), &
15430 
15431  & answer_shape(2) ) &
15432  & )
15433 
15434  answer_negative = answer < 0.0
15435  check_negative = check < 0.0
15436  both_negative = answer_negative .and. check_negative
15437  if (.not. negative_support_on) both_negative = .false.
15438 
15439  judge = answer > check
15440  where (both_negative) judge = .not. judge
15441 
15442  judge_rev = .not. judge
15443  err_flag = any(judge_rev)
15444  mask_array = 1
15445  pos = maxloc(mask_array, judge_rev)
15446 
15447  if (err_flag) then
15448 
15449  wrong = check( &
15450  & pos(1), &
15451 
15452  & pos(2) )
15453 
15454  right = answer( &
15455  & pos(1), &
15456 
15457  & pos(2) )
15458 
15459  write(unit=pos_array(1), fmt="(i20)") pos(1)
15460 
15461  write(unit=pos_array(2), fmt="(i20)") pos(2)
15462 
15463 
15464  pos_str = '(' // &
15465  & trim(adjustl(pos_array(1))) // ',' // &
15466 
15467  & trim(adjustl(pos_array(2))) // ')'
15468 
15469  if ( both_negative( &
15470  & pos(1), &
15471 
15472  & pos(2) ) ) then
15473 
15474  abs_mes = 'ABSOLUTE value of'
15475  else
15476  abs_mes = ''
15477 
15478  end if
15479 
15480  end if
15481  deallocate(mask_array, judge, judge_rev)
15482  deallocate(answer_negative, check_negative, both_negative)
15483 
15484 
15485 
15486 
15487  if (err_flag) then
15488  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15489  write(*,*) ''
15490  write(*,*) ' ' // trim(abs_mes) // &
15491  & ' check' // trim(pos_str) // ' = ', wrong
15492  write(*,*) ' is NOT LESS THAN'
15493  write(*,*) ' ' // trim(abs_mes) // &
15494  & ' answer' // trim(pos_str) // ' = ', right
15495 
15496  call abortprogram('')
15497  else
15498  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15499  end if
15500 
15501 
15502  end subroutine dctestassertlessthanreal2
15503 
15504 
15505  subroutine dctestassertlessthanreal3( &
15506  & message, answer, check, negative_support)
15507  use sysdep, only: abortprogram
15508  use dc_types, only: string, token
15509  implicit none
15510  character(*), intent(in):: message
15511  real, intent(in):: answer(:,:,:)
15512  real, intent(in):: check(:,:,:)
15513  logical, intent(in), optional:: negative_support
15514  logical:: err_flag
15515  logical:: negative_support_on
15516  character(STRING):: pos_str
15517  character(TOKEN):: abs_mes
15518  real:: wrong, right
15519 
15520  integer:: answer_shape(3), check_shape(3), pos(3)
15521  logical:: consist_shape(3)
15522  character(TOKEN):: pos_array(3)
15523  integer, allocatable:: mask_array(:,:,:)
15524  logical, allocatable:: judge(:,:,:)
15525  logical, allocatable:: judge_rev(:,:,:)
15526  logical, allocatable:: answer_negative(:,:,:)
15527  logical, allocatable:: check_negative(:,:,:)
15528  logical, allocatable:: both_negative(:,:,:)
15529 
15530 
15531  continue
15532  if (present(negative_support)) then
15533  negative_support_on = negative_support
15534  else
15535  negative_support_on = .true.
15536  end if
15537 
15538  err_flag = .false.
15539 
15540 
15541  answer_shape = shape(answer)
15542  check_shape = shape(check)
15543 
15544  consist_shape = answer_shape == check_shape
15545 
15546  if (.not. all(consist_shape)) then
15547  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15548  write(*,*) ''
15549  write(*,*) ' shape of check is (', check_shape, ')'
15550  write(*,*) ' is INCORRECT'
15551  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15552 
15553  call abortprogram('')
15554  end if
15555 
15556 
15557  allocate( mask_array( &
15558  & answer_shape(1), &
15559 
15560  & answer_shape(2), &
15561 
15562  & answer_shape(3) ) &
15563  & )
15564 
15565  allocate( judge( &
15566  & answer_shape(1), &
15567 
15568  & answer_shape(2), &
15569 
15570  & answer_shape(3) ) &
15571  & )
15572 
15573  allocate( judge_rev( &
15574  & answer_shape(1), &
15575 
15576  & answer_shape(2), &
15577 
15578  & answer_shape(3) ) &
15579  & )
15580 
15581  allocate( answer_negative( &
15582  & answer_shape(1), &
15583 
15584  & answer_shape(2), &
15585 
15586  & answer_shape(3) ) &
15587  & )
15588 
15589  allocate( check_negative( &
15590  & answer_shape(1), &
15591 
15592  & answer_shape(2), &
15593 
15594  & answer_shape(3) ) &
15595  & )
15596 
15597  allocate( both_negative( &
15598  & answer_shape(1), &
15599 
15600  & answer_shape(2), &
15601 
15602  & answer_shape(3) ) &
15603  & )
15604 
15605  answer_negative = answer < 0.0
15606  check_negative = check < 0.0
15607  both_negative = answer_negative .and. check_negative
15608  if (.not. negative_support_on) both_negative = .false.
15609 
15610  judge = answer > check
15611  where (both_negative) judge = .not. judge
15612 
15613  judge_rev = .not. judge
15614  err_flag = any(judge_rev)
15615  mask_array = 1
15616  pos = maxloc(mask_array, judge_rev)
15617 
15618  if (err_flag) then
15619 
15620  wrong = check( &
15621  & pos(1), &
15622 
15623  & pos(2), &
15624 
15625  & pos(3) )
15626 
15627  right = answer( &
15628  & pos(1), &
15629 
15630  & pos(2), &
15631 
15632  & pos(3) )
15633 
15634  write(unit=pos_array(1), fmt="(i20)") pos(1)
15635 
15636  write(unit=pos_array(2), fmt="(i20)") pos(2)
15637 
15638  write(unit=pos_array(3), fmt="(i20)") pos(3)
15639 
15640 
15641  pos_str = '(' // &
15642  & trim(adjustl(pos_array(1))) // ',' // &
15643 
15644  & trim(adjustl(pos_array(2))) // ',' // &
15645 
15646  & trim(adjustl(pos_array(3))) // ')'
15647 
15648  if ( both_negative( &
15649  & pos(1), &
15650 
15651  & pos(2), &
15652 
15653  & pos(3) ) ) then
15654 
15655  abs_mes = 'ABSOLUTE value of'
15656  else
15657  abs_mes = ''
15658 
15659  end if
15660 
15661  end if
15662  deallocate(mask_array, judge, judge_rev)
15663  deallocate(answer_negative, check_negative, both_negative)
15664 
15665 
15666 
15667 
15668  if (err_flag) then
15669  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15670  write(*,*) ''
15671  write(*,*) ' ' // trim(abs_mes) // &
15672  & ' check' // trim(pos_str) // ' = ', wrong
15673  write(*,*) ' is NOT LESS THAN'
15674  write(*,*) ' ' // trim(abs_mes) // &
15675  & ' answer' // trim(pos_str) // ' = ', right
15676 
15677  call abortprogram('')
15678  else
15679  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15680  end if
15681 
15682 
15683  end subroutine dctestassertlessthanreal3
15684 
15685 
15686  subroutine dctestassertlessthanreal4( &
15687  & message, answer, check, negative_support)
15688  use sysdep, only: abortprogram
15689  use dc_types, only: string, token
15690  implicit none
15691  character(*), intent(in):: message
15692  real, intent(in):: answer(:,:,:,:)
15693  real, intent(in):: check(:,:,:,:)
15694  logical, intent(in), optional:: negative_support
15695  logical:: err_flag
15696  logical:: negative_support_on
15697  character(STRING):: pos_str
15698  character(TOKEN):: abs_mes
15699  real:: wrong, right
15700 
15701  integer:: answer_shape(4), check_shape(4), pos(4)
15702  logical:: consist_shape(4)
15703  character(TOKEN):: pos_array(4)
15704  integer, allocatable:: mask_array(:,:,:,:)
15705  logical, allocatable:: judge(:,:,:,:)
15706  logical, allocatable:: judge_rev(:,:,:,:)
15707  logical, allocatable:: answer_negative(:,:,:,:)
15708  logical, allocatable:: check_negative(:,:,:,:)
15709  logical, allocatable:: both_negative(:,:,:,:)
15710 
15711 
15712  continue
15713  if (present(negative_support)) then
15714  negative_support_on = negative_support
15715  else
15716  negative_support_on = .true.
15717  end if
15718 
15719  err_flag = .false.
15720 
15721 
15722  answer_shape = shape(answer)
15723  check_shape = shape(check)
15724 
15725  consist_shape = answer_shape == check_shape
15726 
15727  if (.not. all(consist_shape)) then
15728  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15729  write(*,*) ''
15730  write(*,*) ' shape of check is (', check_shape, ')'
15731  write(*,*) ' is INCORRECT'
15732  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15733 
15734  call abortprogram('')
15735  end if
15736 
15737 
15738  allocate( mask_array( &
15739  & answer_shape(1), &
15740 
15741  & answer_shape(2), &
15742 
15743  & answer_shape(3), &
15744 
15745  & answer_shape(4) ) &
15746  & )
15747 
15748  allocate( judge( &
15749  & answer_shape(1), &
15750 
15751  & answer_shape(2), &
15752 
15753  & answer_shape(3), &
15754 
15755  & answer_shape(4) ) &
15756  & )
15757 
15758  allocate( judge_rev( &
15759  & answer_shape(1), &
15760 
15761  & answer_shape(2), &
15762 
15763  & answer_shape(3), &
15764 
15765  & answer_shape(4) ) &
15766  & )
15767 
15768  allocate( answer_negative( &
15769  & answer_shape(1), &
15770 
15771  & answer_shape(2), &
15772 
15773  & answer_shape(3), &
15774 
15775  & answer_shape(4) ) &
15776  & )
15777 
15778  allocate( check_negative( &
15779  & answer_shape(1), &
15780 
15781  & answer_shape(2), &
15782 
15783  & answer_shape(3), &
15784 
15785  & answer_shape(4) ) &
15786  & )
15787 
15788  allocate( both_negative( &
15789  & answer_shape(1), &
15790 
15791  & answer_shape(2), &
15792 
15793  & answer_shape(3), &
15794 
15795  & answer_shape(4) ) &
15796  & )
15797 
15798  answer_negative = answer < 0.0
15799  check_negative = check < 0.0
15800  both_negative = answer_negative .and. check_negative
15801  if (.not. negative_support_on) both_negative = .false.
15802 
15803  judge = answer > check
15804  where (both_negative) judge = .not. judge
15805 
15806  judge_rev = .not. judge
15807  err_flag = any(judge_rev)
15808  mask_array = 1
15809  pos = maxloc(mask_array, judge_rev)
15810 
15811  if (err_flag) then
15812 
15813  wrong = check( &
15814  & pos(1), &
15815 
15816  & pos(2), &
15817 
15818  & pos(3), &
15819 
15820  & pos(4) )
15821 
15822  right = answer( &
15823  & pos(1), &
15824 
15825  & pos(2), &
15826 
15827  & pos(3), &
15828 
15829  & pos(4) )
15830 
15831  write(unit=pos_array(1), fmt="(i20)") pos(1)
15832 
15833  write(unit=pos_array(2), fmt="(i20)") pos(2)
15834 
15835  write(unit=pos_array(3), fmt="(i20)") pos(3)
15836 
15837  write(unit=pos_array(4), fmt="(i20)") pos(4)
15838 
15839 
15840  pos_str = '(' // &
15841  & trim(adjustl(pos_array(1))) // ',' // &
15842 
15843  & trim(adjustl(pos_array(2))) // ',' // &
15844 
15845  & trim(adjustl(pos_array(3))) // ',' // &
15846 
15847  & trim(adjustl(pos_array(4))) // ')'
15848 
15849  if ( both_negative( &
15850  & pos(1), &
15851 
15852  & pos(2), &
15853 
15854  & pos(3), &
15855 
15856  & pos(4) ) ) then
15857 
15858  abs_mes = 'ABSOLUTE value of'
15859  else
15860  abs_mes = ''
15861 
15862  end if
15863 
15864  end if
15865  deallocate(mask_array, judge, judge_rev)
15866  deallocate(answer_negative, check_negative, both_negative)
15867 
15868 
15869 
15870 
15871  if (err_flag) then
15872  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15873  write(*,*) ''
15874  write(*,*) ' ' // trim(abs_mes) // &
15875  & ' check' // trim(pos_str) // ' = ', wrong
15876  write(*,*) ' is NOT LESS THAN'
15877  write(*,*) ' ' // trim(abs_mes) // &
15878  & ' answer' // trim(pos_str) // ' = ', right
15879 
15880  call abortprogram('')
15881  else
15882  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15883  end if
15884 
15885 
15886  end subroutine dctestassertlessthanreal4
15887 
15888 
15889  subroutine dctestassertlessthanreal5( &
15890  & message, answer, check, negative_support)
15891  use sysdep, only: abortprogram
15892  use dc_types, only: string, token
15893  implicit none
15894  character(*), intent(in):: message
15895  real, intent(in):: answer(:,:,:,:,:)
15896  real, intent(in):: check(:,:,:,:,:)
15897  logical, intent(in), optional:: negative_support
15898  logical:: err_flag
15899  logical:: negative_support_on
15900  character(STRING):: pos_str
15901  character(TOKEN):: abs_mes
15902  real:: wrong, right
15903 
15904  integer:: answer_shape(5), check_shape(5), pos(5)
15905  logical:: consist_shape(5)
15906  character(TOKEN):: pos_array(5)
15907  integer, allocatable:: mask_array(:,:,:,:,:)
15908  logical, allocatable:: judge(:,:,:,:,:)
15909  logical, allocatable:: judge_rev(:,:,:,:,:)
15910  logical, allocatable:: answer_negative(:,:,:,:,:)
15911  logical, allocatable:: check_negative(:,:,:,:,:)
15912  logical, allocatable:: both_negative(:,:,:,:,:)
15913 
15914 
15915  continue
15916  if (present(negative_support)) then
15917  negative_support_on = negative_support
15918  else
15919  negative_support_on = .true.
15920  end if
15921 
15922  err_flag = .false.
15923 
15924 
15925  answer_shape = shape(answer)
15926  check_shape = shape(check)
15927 
15928  consist_shape = answer_shape == check_shape
15929 
15930  if (.not. all(consist_shape)) then
15931  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15932  write(*,*) ''
15933  write(*,*) ' shape of check is (', check_shape, ')'
15934  write(*,*) ' is INCORRECT'
15935  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15936 
15937  call abortprogram('')
15938  end if
15939 
15940 
15941  allocate( mask_array( &
15942  & answer_shape(1), &
15943 
15944  & answer_shape(2), &
15945 
15946  & answer_shape(3), &
15947 
15948  & answer_shape(4), &
15949 
15950  & answer_shape(5) ) &
15951  & )
15952 
15953  allocate( judge( &
15954  & answer_shape(1), &
15955 
15956  & answer_shape(2), &
15957 
15958  & answer_shape(3), &
15959 
15960  & answer_shape(4), &
15961 
15962  & answer_shape(5) ) &
15963  & )
15964 
15965  allocate( judge_rev( &
15966  & answer_shape(1), &
15967 
15968  & answer_shape(2), &
15969 
15970  & answer_shape(3), &
15971 
15972  & answer_shape(4), &
15973 
15974  & answer_shape(5) ) &
15975  & )
15976 
15977  allocate( answer_negative( &
15978  & answer_shape(1), &
15979 
15980  & answer_shape(2), &
15981 
15982  & answer_shape(3), &
15983 
15984  & answer_shape(4), &
15985 
15986  & answer_shape(5) ) &
15987  & )
15988 
15989  allocate( check_negative( &
15990  & answer_shape(1), &
15991 
15992  & answer_shape(2), &
15993 
15994  & answer_shape(3), &
15995 
15996  & answer_shape(4), &
15997 
15998  & answer_shape(5) ) &
15999  & )
16000 
16001  allocate( both_negative( &
16002  & answer_shape(1), &
16003 
16004  & answer_shape(2), &
16005 
16006  & answer_shape(3), &
16007 
16008  & answer_shape(4), &
16009 
16010  & answer_shape(5) ) &
16011  & )
16012 
16013  answer_negative = answer < 0.0
16014  check_negative = check < 0.0
16015  both_negative = answer_negative .and. check_negative
16016  if (.not. negative_support_on) both_negative = .false.
16017 
16018  judge = answer > check
16019  where (both_negative) judge = .not. judge
16020 
16021  judge_rev = .not. judge
16022  err_flag = any(judge_rev)
16023  mask_array = 1
16024  pos = maxloc(mask_array, judge_rev)
16025 
16026  if (err_flag) then
16027 
16028  wrong = check( &
16029  & pos(1), &
16030 
16031  & pos(2), &
16032 
16033  & pos(3), &
16034 
16035  & pos(4), &
16036 
16037  & pos(5) )
16038 
16039  right = answer( &
16040  & pos(1), &
16041 
16042  & pos(2), &
16043 
16044  & pos(3), &
16045 
16046  & pos(4), &
16047 
16048  & pos(5) )
16049 
16050  write(unit=pos_array(1), fmt="(i20)") pos(1)
16051 
16052  write(unit=pos_array(2), fmt="(i20)") pos(2)
16053 
16054  write(unit=pos_array(3), fmt="(i20)") pos(3)
16055 
16056  write(unit=pos_array(4), fmt="(i20)") pos(4)
16057 
16058  write(unit=pos_array(5), fmt="(i20)") pos(5)
16059 
16060 
16061  pos_str = '(' // &
16062  & trim(adjustl(pos_array(1))) // ',' // &
16063 
16064  & trim(adjustl(pos_array(2))) // ',' // &
16065 
16066  & trim(adjustl(pos_array(3))) // ',' // &
16067 
16068  & trim(adjustl(pos_array(4))) // ',' // &
16069 
16070  & trim(adjustl(pos_array(5))) // ')'
16071 
16072  if ( both_negative( &
16073  & pos(1), &
16074 
16075  & pos(2), &
16076 
16077  & pos(3), &
16078 
16079  & pos(4), &
16080 
16081  & pos(5) ) ) then
16082 
16083  abs_mes = 'ABSOLUTE value of'
16084  else
16085  abs_mes = ''
16086 
16087  end if
16088 
16089  end if
16090  deallocate(mask_array, judge, judge_rev)
16091  deallocate(answer_negative, check_negative, both_negative)
16092 
16093 
16094 
16095 
16096  if (err_flag) then
16097  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16098  write(*,*) ''
16099  write(*,*) ' ' // trim(abs_mes) // &
16100  & ' check' // trim(pos_str) // ' = ', wrong
16101  write(*,*) ' is NOT LESS THAN'
16102  write(*,*) ' ' // trim(abs_mes) // &
16103  & ' answer' // trim(pos_str) // ' = ', right
16104 
16105  call abortprogram('')
16106  else
16107  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16108  end if
16109 
16110 
16111  end subroutine dctestassertlessthanreal5
16112 
16113 
16114  subroutine dctestassertlessthanreal6( &
16115  & message, answer, check, negative_support)
16116  use sysdep, only: abortprogram
16117  use dc_types, only: string, token
16118  implicit none
16119  character(*), intent(in):: message
16120  real, intent(in):: answer(:,:,:,:,:,:)
16121  real, intent(in):: check(:,:,:,:,:,:)
16122  logical, intent(in), optional:: negative_support
16123  logical:: err_flag
16124  logical:: negative_support_on
16125  character(STRING):: pos_str
16126  character(TOKEN):: abs_mes
16127  real:: wrong, right
16128 
16129  integer:: answer_shape(6), check_shape(6), pos(6)
16130  logical:: consist_shape(6)
16131  character(TOKEN):: pos_array(6)
16132  integer, allocatable:: mask_array(:,:,:,:,:,:)
16133  logical, allocatable:: judge(:,:,:,:,:,:)
16134  logical, allocatable:: judge_rev(:,:,:,:,:,:)
16135  logical, allocatable:: answer_negative(:,:,:,:,:,:)
16136  logical, allocatable:: check_negative(:,:,:,:,:,:)
16137  logical, allocatable:: both_negative(:,:,:,:,:,:)
16138 
16139 
16140  continue
16141  if (present(negative_support)) then
16142  negative_support_on = negative_support
16143  else
16144  negative_support_on = .true.
16145  end if
16146 
16147  err_flag = .false.
16148 
16149 
16150  answer_shape = shape(answer)
16151  check_shape = shape(check)
16152 
16153  consist_shape = answer_shape == check_shape
16154 
16155  if (.not. all(consist_shape)) then
16156  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16157  write(*,*) ''
16158  write(*,*) ' shape of check is (', check_shape, ')'
16159  write(*,*) ' is INCORRECT'
16160  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16161 
16162  call abortprogram('')
16163  end if
16164 
16165 
16166  allocate( mask_array( &
16167  & answer_shape(1), &
16168 
16169  & answer_shape(2), &
16170 
16171  & answer_shape(3), &
16172 
16173  & answer_shape(4), &
16174 
16175  & answer_shape(5), &
16176 
16177  & answer_shape(6) ) &
16178  & )
16179 
16180  allocate( judge( &
16181  & answer_shape(1), &
16182 
16183  & answer_shape(2), &
16184 
16185  & answer_shape(3), &
16186 
16187  & answer_shape(4), &
16188 
16189  & answer_shape(5), &
16190 
16191  & answer_shape(6) ) &
16192  & )
16193 
16194  allocate( judge_rev( &
16195  & answer_shape(1), &
16196 
16197  & answer_shape(2), &
16198 
16199  & answer_shape(3), &
16200 
16201  & answer_shape(4), &
16202 
16203  & answer_shape(5), &
16204 
16205  & answer_shape(6) ) &
16206  & )
16207 
16208  allocate( answer_negative( &
16209  & answer_shape(1), &
16210 
16211  & answer_shape(2), &
16212 
16213  & answer_shape(3), &
16214 
16215  & answer_shape(4), &
16216 
16217  & answer_shape(5), &
16218 
16219  & answer_shape(6) ) &
16220  & )
16221 
16222  allocate( check_negative( &
16223  & answer_shape(1), &
16224 
16225  & answer_shape(2), &
16226 
16227  & answer_shape(3), &
16228 
16229  & answer_shape(4), &
16230 
16231  & answer_shape(5), &
16232 
16233  & answer_shape(6) ) &
16234  & )
16235 
16236  allocate( both_negative( &
16237  & answer_shape(1), &
16238 
16239  & answer_shape(2), &
16240 
16241  & answer_shape(3), &
16242 
16243  & answer_shape(4), &
16244 
16245  & answer_shape(5), &
16246 
16247  & answer_shape(6) ) &
16248  & )
16249 
16250  answer_negative = answer < 0.0
16251  check_negative = check < 0.0
16252  both_negative = answer_negative .and. check_negative
16253  if (.not. negative_support_on) both_negative = .false.
16254 
16255  judge = answer > check
16256  where (both_negative) judge = .not. judge
16257 
16258  judge_rev = .not. judge
16259  err_flag = any(judge_rev)
16260  mask_array = 1
16261  pos = maxloc(mask_array, judge_rev)
16262 
16263  if (err_flag) then
16264 
16265  wrong = check( &
16266  & pos(1), &
16267 
16268  & pos(2), &
16269 
16270  & pos(3), &
16271 
16272  & pos(4), &
16273 
16274  & pos(5), &
16275 
16276  & pos(6) )
16277 
16278  right = answer( &
16279  & pos(1), &
16280 
16281  & pos(2), &
16282 
16283  & pos(3), &
16284 
16285  & pos(4), &
16286 
16287  & pos(5), &
16288 
16289  & pos(6) )
16290 
16291  write(unit=pos_array(1), fmt="(i20)") pos(1)
16292 
16293  write(unit=pos_array(2), fmt="(i20)") pos(2)
16294 
16295  write(unit=pos_array(3), fmt="(i20)") pos(3)
16296 
16297  write(unit=pos_array(4), fmt="(i20)") pos(4)
16298 
16299  write(unit=pos_array(5), fmt="(i20)") pos(5)
16300 
16301  write(unit=pos_array(6), fmt="(i20)") pos(6)
16302 
16303 
16304  pos_str = '(' // &
16305  & trim(adjustl(pos_array(1))) // ',' // &
16306 
16307  & trim(adjustl(pos_array(2))) // ',' // &
16308 
16309  & trim(adjustl(pos_array(3))) // ',' // &
16310 
16311  & trim(adjustl(pos_array(4))) // ',' // &
16312 
16313  & trim(adjustl(pos_array(5))) // ',' // &
16314 
16315  & trim(adjustl(pos_array(6))) // ')'
16316 
16317  if ( both_negative( &
16318  & pos(1), &
16319 
16320  & pos(2), &
16321 
16322  & pos(3), &
16323 
16324  & pos(4), &
16325 
16326  & pos(5), &
16327 
16328  & pos(6) ) ) then
16329 
16330  abs_mes = 'ABSOLUTE value of'
16331  else
16332  abs_mes = ''
16333 
16334  end if
16335 
16336  end if
16337  deallocate(mask_array, judge, judge_rev)
16338  deallocate(answer_negative, check_negative, both_negative)
16339 
16340 
16341 
16342 
16343  if (err_flag) then
16344  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16345  write(*,*) ''
16346  write(*,*) ' ' // trim(abs_mes) // &
16347  & ' check' // trim(pos_str) // ' = ', wrong
16348  write(*,*) ' is NOT LESS THAN'
16349  write(*,*) ' ' // trim(abs_mes) // &
16350  & ' answer' // trim(pos_str) // ' = ', right
16351 
16352  call abortprogram('')
16353  else
16354  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16355  end if
16356 
16357 
16358  end subroutine dctestassertlessthanreal6
16359 
16360 
16361  subroutine dctestassertlessthanreal7( &
16362  & message, answer, check, negative_support)
16363  use sysdep, only: abortprogram
16364  use dc_types, only: string, token
16365  implicit none
16366  character(*), intent(in):: message
16367  real, intent(in):: answer(:,:,:,:,:,:,:)
16368  real, intent(in):: check(:,:,:,:,:,:,:)
16369  logical, intent(in), optional:: negative_support
16370  logical:: err_flag
16371  logical:: negative_support_on
16372  character(STRING):: pos_str
16373  character(TOKEN):: abs_mes
16374  real:: wrong, right
16375 
16376  integer:: answer_shape(7), check_shape(7), pos(7)
16377  logical:: consist_shape(7)
16378  character(TOKEN):: pos_array(7)
16379  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
16380  logical, allocatable:: judge(:,:,:,:,:,:,:)
16381  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
16382  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
16383  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
16384  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
16385 
16386 
16387  continue
16388  if (present(negative_support)) then
16389  negative_support_on = negative_support
16390  else
16391  negative_support_on = .true.
16392  end if
16393 
16394  err_flag = .false.
16395 
16396 
16397  answer_shape = shape(answer)
16398  check_shape = shape(check)
16399 
16400  consist_shape = answer_shape == check_shape
16401 
16402  if (.not. all(consist_shape)) then
16403  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16404  write(*,*) ''
16405  write(*,*) ' shape of check is (', check_shape, ')'
16406  write(*,*) ' is INCORRECT'
16407  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16408 
16409  call abortprogram('')
16410  end if
16411 
16412 
16413  allocate( mask_array( &
16414  & answer_shape(1), &
16415 
16416  & answer_shape(2), &
16417 
16418  & answer_shape(3), &
16419 
16420  & answer_shape(4), &
16421 
16422  & answer_shape(5), &
16423 
16424  & answer_shape(6), &
16425 
16426  & answer_shape(7) ) &
16427  & )
16428 
16429  allocate( judge( &
16430  & answer_shape(1), &
16431 
16432  & answer_shape(2), &
16433 
16434  & answer_shape(3), &
16435 
16436  & answer_shape(4), &
16437 
16438  & answer_shape(5), &
16439 
16440  & answer_shape(6), &
16441 
16442  & answer_shape(7) ) &
16443  & )
16444 
16445  allocate( judge_rev( &
16446  & answer_shape(1), &
16447 
16448  & answer_shape(2), &
16449 
16450  & answer_shape(3), &
16451 
16452  & answer_shape(4), &
16453 
16454  & answer_shape(5), &
16455 
16456  & answer_shape(6), &
16457 
16458  & answer_shape(7) ) &
16459  & )
16460 
16461  allocate( answer_negative( &
16462  & answer_shape(1), &
16463 
16464  & answer_shape(2), &
16465 
16466  & answer_shape(3), &
16467 
16468  & answer_shape(4), &
16469 
16470  & answer_shape(5), &
16471 
16472  & answer_shape(6), &
16473 
16474  & answer_shape(7) ) &
16475  & )
16476 
16477  allocate( check_negative( &
16478  & answer_shape(1), &
16479 
16480  & answer_shape(2), &
16481 
16482  & answer_shape(3), &
16483 
16484  & answer_shape(4), &
16485 
16486  & answer_shape(5), &
16487 
16488  & answer_shape(6), &
16489 
16490  & answer_shape(7) ) &
16491  & )
16492 
16493  allocate( both_negative( &
16494  & answer_shape(1), &
16495 
16496  & answer_shape(2), &
16497 
16498  & answer_shape(3), &
16499 
16500  & answer_shape(4), &
16501 
16502  & answer_shape(5), &
16503 
16504  & answer_shape(6), &
16505 
16506  & answer_shape(7) ) &
16507  & )
16508 
16509  answer_negative = answer < 0.0
16510  check_negative = check < 0.0
16511  both_negative = answer_negative .and. check_negative
16512  if (.not. negative_support_on) both_negative = .false.
16513 
16514  judge = answer > check
16515  where (both_negative) judge = .not. judge
16516 
16517  judge_rev = .not. judge
16518  err_flag = any(judge_rev)
16519  mask_array = 1
16520  pos = maxloc(mask_array, judge_rev)
16521 
16522  if (err_flag) then
16523 
16524  wrong = check( &
16525  & pos(1), &
16526 
16527  & pos(2), &
16528 
16529  & pos(3), &
16530 
16531  & pos(4), &
16532 
16533  & pos(5), &
16534 
16535  & pos(6), &
16536 
16537  & pos(7) )
16538 
16539  right = answer( &
16540  & pos(1), &
16541 
16542  & pos(2), &
16543 
16544  & pos(3), &
16545 
16546  & pos(4), &
16547 
16548  & pos(5), &
16549 
16550  & pos(6), &
16551 
16552  & pos(7) )
16553 
16554  write(unit=pos_array(1), fmt="(i20)") pos(1)
16555 
16556  write(unit=pos_array(2), fmt="(i20)") pos(2)
16557 
16558  write(unit=pos_array(3), fmt="(i20)") pos(3)
16559 
16560  write(unit=pos_array(4), fmt="(i20)") pos(4)
16561 
16562  write(unit=pos_array(5), fmt="(i20)") pos(5)
16563 
16564  write(unit=pos_array(6), fmt="(i20)") pos(6)
16565 
16566  write(unit=pos_array(7), fmt="(i20)") pos(7)
16567 
16568 
16569  pos_str = '(' // &
16570  & trim(adjustl(pos_array(1))) // ',' // &
16571 
16572  & trim(adjustl(pos_array(2))) // ',' // &
16573 
16574  & trim(adjustl(pos_array(3))) // ',' // &
16575 
16576  & trim(adjustl(pos_array(4))) // ',' // &
16577 
16578  & trim(adjustl(pos_array(5))) // ',' // &
16579 
16580  & trim(adjustl(pos_array(6))) // ',' // &
16581 
16582  & trim(adjustl(pos_array(7))) // ')'
16583 
16584  if ( both_negative( &
16585  & pos(1), &
16586 
16587  & pos(2), &
16588 
16589  & pos(3), &
16590 
16591  & pos(4), &
16592 
16593  & pos(5), &
16594 
16595  & pos(6), &
16596 
16597  & pos(7) ) ) then
16598 
16599  abs_mes = 'ABSOLUTE value of'
16600  else
16601  abs_mes = ''
16602 
16603  end if
16604 
16605  end if
16606  deallocate(mask_array, judge, judge_rev)
16607  deallocate(answer_negative, check_negative, both_negative)
16608 
16609 
16610 
16611 
16612  if (err_flag) then
16613  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16614  write(*,*) ''
16615  write(*,*) ' ' // trim(abs_mes) // &
16616  & ' check' // trim(pos_str) // ' = ', wrong
16617  write(*,*) ' is NOT LESS THAN'
16618  write(*,*) ' ' // trim(abs_mes) // &
16619  & ' answer' // trim(pos_str) // ' = ', right
16620 
16621  call abortprogram('')
16622  else
16623  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16624  end if
16625 
16626 
16627  end subroutine dctestassertlessthanreal7
16628 
16629 
16630  subroutine dctestassertlessthandouble0( &
16631  & message, answer, check, negative_support)
16632  use sysdep, only: abortprogram
16633  use dc_types, only: string, token
16634  implicit none
16635  character(*), intent(in):: message
16636  real(DP), intent(in):: answer
16637  real(DP), intent(in):: check
16638  logical, intent(in), optional:: negative_support
16639  logical:: err_flag
16640  logical:: negative_support_on
16641  character(STRING):: pos_str
16642  character(TOKEN):: abs_mes
16643  real(DP):: wrong, right
16644 
16645 
16646 
16647  continue
16648  if (present(negative_support)) then
16649  negative_support_on = negative_support
16650  else
16651  negative_support_on = .true.
16652  end if
16653 
16654  err_flag = .false.
16655 
16656 
16657 
16658 
16659  err_flag = .not. answer > check
16660  abs_mes = ''
16661 
16662  if ( answer < 0.0_dp &
16663  & .and. check < 0.0_dp &
16664  & .and. negative_support_on ) then
16665 
16666  err_flag = .not. err_flag
16667  abs_mes = 'ABSOLUTE value of'
16668  end if
16669 
16670  wrong = check
16671  right = answer
16672  pos_str = ''
16673 
16674 
16675 
16676 
16677  if (err_flag) then
16678  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16679  write(*,*) ''
16680  write(*,*) ' ' // trim(abs_mes) // &
16681  & ' check' // trim(pos_str) // ' = ', wrong
16682  write(*,*) ' is NOT LESS THAN'
16683  write(*,*) ' ' // trim(abs_mes) // &
16684  & ' answer' // trim(pos_str) // ' = ', right
16685 
16686  call abortprogram('')
16687  else
16688  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16689  end if
16690 
16691 
16692  end subroutine dctestassertlessthandouble0
16693 
16694 
16695  subroutine dctestassertlessthandouble1( &
16696  & message, answer, check, negative_support)
16697  use sysdep, only: abortprogram
16698  use dc_types, only: string, token
16699  implicit none
16700  character(*), intent(in):: message
16701  real(DP), intent(in):: answer(:)
16702  real(DP), intent(in):: check(:)
16703  logical, intent(in), optional:: negative_support
16704  logical:: err_flag
16705  logical:: negative_support_on
16706  character(STRING):: pos_str
16707  character(TOKEN):: abs_mes
16708  real(DP):: wrong, right
16709 
16710  integer:: answer_shape(1), check_shape(1), pos(1)
16711  logical:: consist_shape(1)
16712  character(TOKEN):: pos_array(1)
16713  integer, allocatable:: mask_array(:)
16714  logical, allocatable:: judge(:)
16715  logical, allocatable:: judge_rev(:)
16716  logical, allocatable:: answer_negative(:)
16717  logical, allocatable:: check_negative(:)
16718  logical, allocatable:: both_negative(:)
16719 
16720 
16721  continue
16722  if (present(negative_support)) then
16723  negative_support_on = negative_support
16724  else
16725  negative_support_on = .true.
16726  end if
16727 
16728  err_flag = .false.
16729 
16730 
16731  answer_shape = shape(answer)
16732  check_shape = shape(check)
16733 
16734  consist_shape = answer_shape == check_shape
16735 
16736  if (.not. all(consist_shape)) then
16737  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16738  write(*,*) ''
16739  write(*,*) ' shape of check is (', check_shape, ')'
16740  write(*,*) ' is INCORRECT'
16741  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16742 
16743  call abortprogram('')
16744  end if
16745 
16746 
16747  allocate( mask_array( &
16748 
16749  & answer_shape(1) ) &
16750  & )
16751 
16752  allocate( judge( &
16753 
16754  & answer_shape(1) ) &
16755  & )
16756 
16757  allocate( judge_rev( &
16758 
16759  & answer_shape(1) ) &
16760  & )
16761 
16762  allocate( answer_negative( &
16763 
16764  & answer_shape(1) ) &
16765  & )
16766 
16767  allocate( check_negative( &
16768 
16769  & answer_shape(1) ) &
16770  & )
16771 
16772  allocate( both_negative( &
16773 
16774  & answer_shape(1) ) &
16775  & )
16776 
16777  answer_negative = answer < 0.0_dp
16778  check_negative = check < 0.0_dp
16779  both_negative = answer_negative .and. check_negative
16780  if (.not. negative_support_on) both_negative = .false.
16781 
16782  judge = answer > check
16783  where (both_negative) judge = .not. judge
16784 
16785  judge_rev = .not. judge
16786  err_flag = any(judge_rev)
16787  mask_array = 1
16788  pos = maxloc(mask_array, judge_rev)
16789 
16790  if (err_flag) then
16791 
16792  wrong = check( &
16793 
16794  & pos(1) )
16795 
16796  right = answer( &
16797 
16798  & pos(1) )
16799 
16800  write(unit=pos_array(1), fmt="(i20)") pos(1)
16801 
16802 
16803  pos_str = '(' // &
16804 
16805  & trim(adjustl(pos_array(1))) // ')'
16806 
16807  if ( both_negative( &
16808 
16809  & pos(1) ) ) then
16810 
16811  abs_mes = 'ABSOLUTE value of'
16812  else
16813  abs_mes = ''
16814 
16815  end if
16816 
16817  end if
16818  deallocate(mask_array, judge, judge_rev)
16819  deallocate(answer_negative, check_negative, both_negative)
16820 
16821 
16822 
16823 
16824  if (err_flag) then
16825  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16826  write(*,*) ''
16827  write(*,*) ' ' // trim(abs_mes) // &
16828  & ' check' // trim(pos_str) // ' = ', wrong
16829  write(*,*) ' is NOT LESS THAN'
16830  write(*,*) ' ' // trim(abs_mes) // &
16831  & ' answer' // trim(pos_str) // ' = ', right
16832 
16833  call abortprogram('')
16834  else
16835  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16836  end if
16837 
16838 
16839  end subroutine dctestassertlessthandouble1
16840 
16841 
16842  subroutine dctestassertlessthandouble2( &
16843  & message, answer, check, negative_support)
16844  use sysdep, only: abortprogram
16845  use dc_types, only: string, token
16846  implicit none
16847  character(*), intent(in):: message
16848  real(DP), intent(in):: answer(:,:)
16849  real(DP), intent(in):: check(:,:)
16850  logical, intent(in), optional:: negative_support
16851  logical:: err_flag
16852  logical:: negative_support_on
16853  character(STRING):: pos_str
16854  character(TOKEN):: abs_mes
16855  real(DP):: wrong, right
16856 
16857  integer:: answer_shape(2), check_shape(2), pos(2)
16858  logical:: consist_shape(2)
16859  character(TOKEN):: pos_array(2)
16860  integer, allocatable:: mask_array(:,:)
16861  logical, allocatable:: judge(:,:)
16862  logical, allocatable:: judge_rev(:,:)
16863  logical, allocatable:: answer_negative(:,:)
16864  logical, allocatable:: check_negative(:,:)
16865  logical, allocatable:: both_negative(:,:)
16866 
16867 
16868  continue
16869  if (present(negative_support)) then
16870  negative_support_on = negative_support
16871  else
16872  negative_support_on = .true.
16873  end if
16874 
16875  err_flag = .false.
16876 
16877 
16878  answer_shape = shape(answer)
16879  check_shape = shape(check)
16880 
16881  consist_shape = answer_shape == check_shape
16882 
16883  if (.not. all(consist_shape)) then
16884  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16885  write(*,*) ''
16886  write(*,*) ' shape of check is (', check_shape, ')'
16887  write(*,*) ' is INCORRECT'
16888  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16889 
16890  call abortprogram('')
16891  end if
16892 
16893 
16894  allocate( mask_array( &
16895  & answer_shape(1), &
16896 
16897  & answer_shape(2) ) &
16898  & )
16899 
16900  allocate( judge( &
16901  & answer_shape(1), &
16902 
16903  & answer_shape(2) ) &
16904  & )
16905 
16906  allocate( judge_rev( &
16907  & answer_shape(1), &
16908 
16909  & answer_shape(2) ) &
16910  & )
16911 
16912  allocate( answer_negative( &
16913  & answer_shape(1), &
16914 
16915  & answer_shape(2) ) &
16916  & )
16917 
16918  allocate( check_negative( &
16919  & answer_shape(1), &
16920 
16921  & answer_shape(2) ) &
16922  & )
16923 
16924  allocate( both_negative( &
16925  & answer_shape(1), &
16926 
16927  & answer_shape(2) ) &
16928  & )
16929 
16930  answer_negative = answer < 0.0_dp
16931  check_negative = check < 0.0_dp
16932  both_negative = answer_negative .and. check_negative
16933  if (.not. negative_support_on) both_negative = .false.
16934 
16935  judge = answer > check
16936  where (both_negative) judge = .not. judge
16937 
16938  judge_rev = .not. judge
16939  err_flag = any(judge_rev)
16940  mask_array = 1
16941  pos = maxloc(mask_array, judge_rev)
16942 
16943  if (err_flag) then
16944 
16945  wrong = check( &
16946  & pos(1), &
16947 
16948  & pos(2) )
16949 
16950  right = answer( &
16951  & pos(1), &
16952 
16953  & pos(2) )
16954 
16955  write(unit=pos_array(1), fmt="(i20)") pos(1)
16956 
16957  write(unit=pos_array(2), fmt="(i20)") pos(2)
16958 
16959 
16960  pos_str = '(' // &
16961  & trim(adjustl(pos_array(1))) // ',' // &
16962 
16963  & trim(adjustl(pos_array(2))) // ')'
16964 
16965  if ( both_negative( &
16966  & pos(1), &
16967 
16968  & pos(2) ) ) then
16969 
16970  abs_mes = 'ABSOLUTE value of'
16971  else
16972  abs_mes = ''
16973 
16974  end if
16975 
16976  end if
16977  deallocate(mask_array, judge, judge_rev)
16978  deallocate(answer_negative, check_negative, both_negative)
16979 
16980 
16981 
16982 
16983  if (err_flag) then
16984  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16985  write(*,*) ''
16986  write(*,*) ' ' // trim(abs_mes) // &
16987  & ' check' // trim(pos_str) // ' = ', wrong
16988  write(*,*) ' is NOT LESS THAN'
16989  write(*,*) ' ' // trim(abs_mes) // &
16990  & ' answer' // trim(pos_str) // ' = ', right
16991 
16992  call abortprogram('')
16993  else
16994  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16995  end if
16996 
16997 
16998  end subroutine dctestassertlessthandouble2
16999 
17000 
17001  subroutine dctestassertlessthandouble3( &
17002  & message, answer, check, negative_support)
17003  use sysdep, only: abortprogram
17004  use dc_types, only: string, token
17005  implicit none
17006  character(*), intent(in):: message
17007  real(DP), intent(in):: answer(:,:,:)
17008  real(DP), intent(in):: check(:,:,:)
17009  logical, intent(in), optional:: negative_support
17010  logical:: err_flag
17011  logical:: negative_support_on
17012  character(STRING):: pos_str
17013  character(TOKEN):: abs_mes
17014  real(DP):: wrong, right
17015 
17016  integer:: answer_shape(3), check_shape(3), pos(3)
17017  logical:: consist_shape(3)
17018  character(TOKEN):: pos_array(3)
17019  integer, allocatable:: mask_array(:,:,:)
17020  logical, allocatable:: judge(:,:,:)
17021  logical, allocatable:: judge_rev(:,:,:)
17022  logical, allocatable:: answer_negative(:,:,:)
17023  logical, allocatable:: check_negative(:,:,:)
17024  logical, allocatable:: both_negative(:,:,:)
17025 
17026 
17027  continue
17028  if (present(negative_support)) then
17029  negative_support_on = negative_support
17030  else
17031  negative_support_on = .true.
17032  end if
17033 
17034  err_flag = .false.
17035 
17036 
17037  answer_shape = shape(answer)
17038  check_shape = shape(check)
17039 
17040  consist_shape = answer_shape == check_shape
17041 
17042  if (.not. all(consist_shape)) then
17043  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17044  write(*,*) ''
17045  write(*,*) ' shape of check is (', check_shape, ')'
17046  write(*,*) ' is INCORRECT'
17047  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17048 
17049  call abortprogram('')
17050  end if
17051 
17052 
17053  allocate( mask_array( &
17054  & answer_shape(1), &
17055 
17056  & answer_shape(2), &
17057 
17058  & answer_shape(3) ) &
17059  & )
17060 
17061  allocate( judge( &
17062  & answer_shape(1), &
17063 
17064  & answer_shape(2), &
17065 
17066  & answer_shape(3) ) &
17067  & )
17068 
17069  allocate( judge_rev( &
17070  & answer_shape(1), &
17071 
17072  & answer_shape(2), &
17073 
17074  & answer_shape(3) ) &
17075  & )
17076 
17077  allocate( answer_negative( &
17078  & answer_shape(1), &
17079 
17080  & answer_shape(2), &
17081 
17082  & answer_shape(3) ) &
17083  & )
17084 
17085  allocate( check_negative( &
17086  & answer_shape(1), &
17087 
17088  & answer_shape(2), &
17089 
17090  & answer_shape(3) ) &
17091  & )
17092 
17093  allocate( both_negative( &
17094  & answer_shape(1), &
17095 
17096  & answer_shape(2), &
17097 
17098  & answer_shape(3) ) &
17099  & )
17100 
17101  answer_negative = answer < 0.0_dp
17102  check_negative = check < 0.0_dp
17103  both_negative = answer_negative .and. check_negative
17104  if (.not. negative_support_on) both_negative = .false.
17105 
17106  judge = answer > check
17107  where (both_negative) judge = .not. judge
17108 
17109  judge_rev = .not. judge
17110  err_flag = any(judge_rev)
17111  mask_array = 1
17112  pos = maxloc(mask_array, judge_rev)
17113 
17114  if (err_flag) then
17115 
17116  wrong = check( &
17117  & pos(1), &
17118 
17119  & pos(2), &
17120 
17121  & pos(3) )
17122 
17123  right = answer( &
17124  & pos(1), &
17125 
17126  & pos(2), &
17127 
17128  & pos(3) )
17129 
17130  write(unit=pos_array(1), fmt="(i20)") pos(1)
17131 
17132  write(unit=pos_array(2), fmt="(i20)") pos(2)
17133 
17134  write(unit=pos_array(3), fmt="(i20)") pos(3)
17135 
17136 
17137  pos_str = '(' // &
17138  & trim(adjustl(pos_array(1))) // ',' // &
17139 
17140  & trim(adjustl(pos_array(2))) // ',' // &
17141 
17142  & trim(adjustl(pos_array(3))) // ')'
17143 
17144  if ( both_negative( &
17145  & pos(1), &
17146 
17147  & pos(2), &
17148 
17149  & pos(3) ) ) then
17150 
17151  abs_mes = 'ABSOLUTE value of'
17152  else
17153  abs_mes = ''
17154 
17155  end if
17156 
17157  end if
17158  deallocate(mask_array, judge, judge_rev)
17159  deallocate(answer_negative, check_negative, both_negative)
17160 
17161 
17162 
17163 
17164  if (err_flag) then
17165  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17166  write(*,*) ''
17167  write(*,*) ' ' // trim(abs_mes) // &
17168  & ' check' // trim(pos_str) // ' = ', wrong
17169  write(*,*) ' is NOT LESS THAN'
17170  write(*,*) ' ' // trim(abs_mes) // &
17171  & ' answer' // trim(pos_str) // ' = ', right
17172 
17173  call abortprogram('')
17174  else
17175  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17176  end if
17177 
17178 
17179  end subroutine dctestassertlessthandouble3
17180 
17181 
17182  subroutine dctestassertlessthandouble4( &
17183  & message, answer, check, negative_support)
17184  use sysdep, only: abortprogram
17185  use dc_types, only: string, token
17186  implicit none
17187  character(*), intent(in):: message
17188  real(DP), intent(in):: answer(:,:,:,:)
17189  real(DP), intent(in):: check(:,:,:,:)
17190  logical, intent(in), optional:: negative_support
17191  logical:: err_flag
17192  logical:: negative_support_on
17193  character(STRING):: pos_str
17194  character(TOKEN):: abs_mes
17195  real(DP):: wrong, right
17196 
17197  integer:: answer_shape(4), check_shape(4), pos(4)
17198  logical:: consist_shape(4)
17199  character(TOKEN):: pos_array(4)
17200  integer, allocatable:: mask_array(:,:,:,:)
17201  logical, allocatable:: judge(:,:,:,:)
17202  logical, allocatable:: judge_rev(:,:,:,:)
17203  logical, allocatable:: answer_negative(:,:,:,:)
17204  logical, allocatable:: check_negative(:,:,:,:)
17205  logical, allocatable:: both_negative(:,:,:,:)
17206 
17207 
17208  continue
17209  if (present(negative_support)) then
17210  negative_support_on = negative_support
17211  else
17212  negative_support_on = .true.
17213  end if
17214 
17215  err_flag = .false.
17216 
17217 
17218  answer_shape = shape(answer)
17219  check_shape = shape(check)
17220 
17221  consist_shape = answer_shape == check_shape
17222 
17223  if (.not. all(consist_shape)) then
17224  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17225  write(*,*) ''
17226  write(*,*) ' shape of check is (', check_shape, ')'
17227  write(*,*) ' is INCORRECT'
17228  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17229 
17230  call abortprogram('')
17231  end if
17232 
17233 
17234  allocate( mask_array( &
17235  & answer_shape(1), &
17236 
17237  & answer_shape(2), &
17238 
17239  & answer_shape(3), &
17240 
17241  & answer_shape(4) ) &
17242  & )
17243 
17244  allocate( judge( &
17245  & answer_shape(1), &
17246 
17247  & answer_shape(2), &
17248 
17249  & answer_shape(3), &
17250 
17251  & answer_shape(4) ) &
17252  & )
17253 
17254  allocate( judge_rev( &
17255  & answer_shape(1), &
17256 
17257  & answer_shape(2), &
17258 
17259  & answer_shape(3), &
17260 
17261  & answer_shape(4) ) &
17262  & )
17263 
17264  allocate( answer_negative( &
17265  & answer_shape(1), &
17266 
17267  & answer_shape(2), &
17268 
17269  & answer_shape(3), &
17270 
17271  & answer_shape(4) ) &
17272  & )
17273 
17274  allocate( check_negative( &
17275  & answer_shape(1), &
17276 
17277  & answer_shape(2), &
17278 
17279  & answer_shape(3), &
17280 
17281  & answer_shape(4) ) &
17282  & )
17283 
17284  allocate( both_negative( &
17285  & answer_shape(1), &
17286 
17287  & answer_shape(2), &
17288 
17289  & answer_shape(3), &
17290 
17291  & answer_shape(4) ) &
17292  & )
17293 
17294  answer_negative = answer < 0.0_dp
17295  check_negative = check < 0.0_dp
17296  both_negative = answer_negative .and. check_negative
17297  if (.not. negative_support_on) both_negative = .false.
17298 
17299  judge = answer > check
17300  where (both_negative) judge = .not. judge
17301 
17302  judge_rev = .not. judge
17303  err_flag = any(judge_rev)
17304  mask_array = 1
17305  pos = maxloc(mask_array, judge_rev)
17306 
17307  if (err_flag) then
17308 
17309  wrong = check( &
17310  & pos(1), &
17311 
17312  & pos(2), &
17313 
17314  & pos(3), &
17315 
17316  & pos(4) )
17317 
17318  right = answer( &
17319  & pos(1), &
17320 
17321  & pos(2), &
17322 
17323  & pos(3), &
17324 
17325  & pos(4) )
17326 
17327  write(unit=pos_array(1), fmt="(i20)") pos(1)
17328 
17329  write(unit=pos_array(2), fmt="(i20)") pos(2)
17330 
17331  write(unit=pos_array(3), fmt="(i20)") pos(3)
17332 
17333  write(unit=pos_array(4), fmt="(i20)") pos(4)
17334 
17335 
17336  pos_str = '(' // &
17337  & trim(adjustl(pos_array(1))) // ',' // &
17338 
17339  & trim(adjustl(pos_array(2))) // ',' // &
17340 
17341  & trim(adjustl(pos_array(3))) // ',' // &
17342 
17343  & trim(adjustl(pos_array(4))) // ')'
17344 
17345  if ( both_negative( &
17346  & pos(1), &
17347 
17348  & pos(2), &
17349 
17350  & pos(3), &
17351 
17352  & pos(4) ) ) then
17353 
17354  abs_mes = 'ABSOLUTE value of'
17355  else
17356  abs_mes = ''
17357 
17358  end if
17359 
17360  end if
17361  deallocate(mask_array, judge, judge_rev)
17362  deallocate(answer_negative, check_negative, both_negative)
17363 
17364 
17365 
17366 
17367  if (err_flag) then
17368  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17369  write(*,*) ''
17370  write(*,*) ' ' // trim(abs_mes) // &
17371  & ' check' // trim(pos_str) // ' = ', wrong
17372  write(*,*) ' is NOT LESS THAN'
17373  write(*,*) ' ' // trim(abs_mes) // &
17374  & ' answer' // trim(pos_str) // ' = ', right
17375 
17376  call abortprogram('')
17377  else
17378  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17379  end if
17380 
17381 
17382  end subroutine dctestassertlessthandouble4
17383 
17384 
17385  subroutine dctestassertlessthandouble5( &
17386  & message, answer, check, negative_support)
17387  use sysdep, only: abortprogram
17388  use dc_types, only: string, token
17389  implicit none
17390  character(*), intent(in):: message
17391  real(DP), intent(in):: answer(:,:,:,:,:)
17392  real(DP), intent(in):: check(:,:,:,:,:)
17393  logical, intent(in), optional:: negative_support
17394  logical:: err_flag
17395  logical:: negative_support_on
17396  character(STRING):: pos_str
17397  character(TOKEN):: abs_mes
17398  real(DP):: wrong, right
17399 
17400  integer:: answer_shape(5), check_shape(5), pos(5)
17401  logical:: consist_shape(5)
17402  character(TOKEN):: pos_array(5)
17403  integer, allocatable:: mask_array(:,:,:,:,:)
17404  logical, allocatable:: judge(:,:,:,:,:)
17405  logical, allocatable:: judge_rev(:,:,:,:,:)
17406  logical, allocatable:: answer_negative(:,:,:,:,:)
17407  logical, allocatable:: check_negative(:,:,:,:,:)
17408  logical, allocatable:: both_negative(:,:,:,:,:)
17409 
17410 
17411  continue
17412  if (present(negative_support)) then
17413  negative_support_on = negative_support
17414  else
17415  negative_support_on = .true.
17416  end if
17417 
17418  err_flag = .false.
17419 
17420 
17421  answer_shape = shape(answer)
17422  check_shape = shape(check)
17423 
17424  consist_shape = answer_shape == check_shape
17425 
17426  if (.not. all(consist_shape)) then
17427  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17428  write(*,*) ''
17429  write(*,*) ' shape of check is (', check_shape, ')'
17430  write(*,*) ' is INCORRECT'
17431  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17432 
17433  call abortprogram('')
17434  end if
17435 
17436 
17437  allocate( mask_array( &
17438  & answer_shape(1), &
17439 
17440  & answer_shape(2), &
17441 
17442  & answer_shape(3), &
17443 
17444  & answer_shape(4), &
17445 
17446  & answer_shape(5) ) &
17447  & )
17448 
17449  allocate( judge( &
17450  & answer_shape(1), &
17451 
17452  & answer_shape(2), &
17453 
17454  & answer_shape(3), &
17455 
17456  & answer_shape(4), &
17457 
17458  & answer_shape(5) ) &
17459  & )
17460 
17461  allocate( judge_rev( &
17462  & answer_shape(1), &
17463 
17464  & answer_shape(2), &
17465 
17466  & answer_shape(3), &
17467 
17468  & answer_shape(4), &
17469 
17470  & answer_shape(5) ) &
17471  & )
17472 
17473  allocate( answer_negative( &
17474  & answer_shape(1), &
17475 
17476  & answer_shape(2), &
17477 
17478  & answer_shape(3), &
17479 
17480  & answer_shape(4), &
17481 
17482  & answer_shape(5) ) &
17483  & )
17484 
17485  allocate( check_negative( &
17486  & answer_shape(1), &
17487 
17488  & answer_shape(2), &
17489 
17490  & answer_shape(3), &
17491 
17492  & answer_shape(4), &
17493 
17494  & answer_shape(5) ) &
17495  & )
17496 
17497  allocate( both_negative( &
17498  & answer_shape(1), &
17499 
17500  & answer_shape(2), &
17501 
17502  & answer_shape(3), &
17503 
17504  & answer_shape(4), &
17505 
17506  & answer_shape(5) ) &
17507  & )
17508 
17509  answer_negative = answer < 0.0_dp
17510  check_negative = check < 0.0_dp
17511  both_negative = answer_negative .and. check_negative
17512  if (.not. negative_support_on) both_negative = .false.
17513 
17514  judge = answer > check
17515  where (both_negative) judge = .not. judge
17516 
17517  judge_rev = .not. judge
17518  err_flag = any(judge_rev)
17519  mask_array = 1
17520  pos = maxloc(mask_array, judge_rev)
17521 
17522  if (err_flag) then
17523 
17524  wrong = check( &
17525  & pos(1), &
17526 
17527  & pos(2), &
17528 
17529  & pos(3), &
17530 
17531  & pos(4), &
17532 
17533  & pos(5) )
17534 
17535  right = answer( &
17536  & pos(1), &
17537 
17538  & pos(2), &
17539 
17540  & pos(3), &
17541 
17542  & pos(4), &
17543 
17544  & pos(5) )
17545 
17546  write(unit=pos_array(1), fmt="(i20)") pos(1)
17547 
17548  write(unit=pos_array(2), fmt="(i20)") pos(2)
17549 
17550  write(unit=pos_array(3), fmt="(i20)") pos(3)
17551 
17552  write(unit=pos_array(4), fmt="(i20)") pos(4)
17553 
17554  write(unit=pos_array(5), fmt="(i20)") pos(5)
17555 
17556 
17557  pos_str = '(' // &
17558  & trim(adjustl(pos_array(1))) // ',' // &
17559 
17560  & trim(adjustl(pos_array(2))) // ',' // &
17561 
17562  & trim(adjustl(pos_array(3))) // ',' // &
17563 
17564  & trim(adjustl(pos_array(4))) // ',' // &
17565 
17566  & trim(adjustl(pos_array(5))) // ')'
17567 
17568  if ( both_negative( &
17569  & pos(1), &
17570 
17571  & pos(2), &
17572 
17573  & pos(3), &
17574 
17575  & pos(4), &
17576 
17577  & pos(5) ) ) then
17578 
17579  abs_mes = 'ABSOLUTE value of'
17580  else
17581  abs_mes = ''
17582 
17583  end if
17584 
17585  end if
17586  deallocate(mask_array, judge, judge_rev)
17587  deallocate(answer_negative, check_negative, both_negative)
17588 
17589 
17590 
17591 
17592  if (err_flag) then
17593  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17594  write(*,*) ''
17595  write(*,*) ' ' // trim(abs_mes) // &
17596  & ' check' // trim(pos_str) // ' = ', wrong
17597  write(*,*) ' is NOT LESS THAN'
17598  write(*,*) ' ' // trim(abs_mes) // &
17599  & ' answer' // trim(pos_str) // ' = ', right
17600 
17601  call abortprogram('')
17602  else
17603  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17604  end if
17605 
17606 
17607  end subroutine dctestassertlessthandouble5
17608 
17609 
17610  subroutine dctestassertlessthandouble6( &
17611  & message, answer, check, negative_support)
17612  use sysdep, only: abortprogram
17613  use dc_types, only: string, token
17614  implicit none
17615  character(*), intent(in):: message
17616  real(DP), intent(in):: answer(:,:,:,:,:,:)
17617  real(DP), intent(in):: check(:,:,:,:,:,:)
17618  logical, intent(in), optional:: negative_support
17619  logical:: err_flag
17620  logical:: negative_support_on
17621  character(STRING):: pos_str
17622  character(TOKEN):: abs_mes
17623  real(DP):: wrong, right
17624 
17625  integer:: answer_shape(6), check_shape(6), pos(6)
17626  logical:: consist_shape(6)
17627  character(TOKEN):: pos_array(6)
17628  integer, allocatable:: mask_array(:,:,:,:,:,:)
17629  logical, allocatable:: judge(:,:,:,:,:,:)
17630  logical, allocatable:: judge_rev(:,:,:,:,:,:)
17631  logical, allocatable:: answer_negative(:,:,:,:,:,:)
17632  logical, allocatable:: check_negative(:,:,:,:,:,:)
17633  logical, allocatable:: both_negative(:,:,:,:,:,:)
17634 
17635 
17636  continue
17637  if (present(negative_support)) then
17638  negative_support_on = negative_support
17639  else
17640  negative_support_on = .true.
17641  end if
17642 
17643  err_flag = .false.
17644 
17645 
17646  answer_shape = shape(answer)
17647  check_shape = shape(check)
17648 
17649  consist_shape = answer_shape == check_shape
17650 
17651  if (.not. all(consist_shape)) then
17652  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17653  write(*,*) ''
17654  write(*,*) ' shape of check is (', check_shape, ')'
17655  write(*,*) ' is INCORRECT'
17656  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17657 
17658  call abortprogram('')
17659  end if
17660 
17661 
17662  allocate( mask_array( &
17663  & answer_shape(1), &
17664 
17665  & answer_shape(2), &
17666 
17667  & answer_shape(3), &
17668 
17669  & answer_shape(4), &
17670 
17671  & answer_shape(5), &
17672 
17673  & answer_shape(6) ) &
17674  & )
17675 
17676  allocate( judge( &
17677  & answer_shape(1), &
17678 
17679  & answer_shape(2), &
17680 
17681  & answer_shape(3), &
17682 
17683  & answer_shape(4), &
17684 
17685  & answer_shape(5), &
17686 
17687  & answer_shape(6) ) &
17688  & )
17689 
17690  allocate( judge_rev( &
17691  & answer_shape(1), &
17692 
17693  & answer_shape(2), &
17694 
17695  & answer_shape(3), &
17696 
17697  & answer_shape(4), &
17698 
17699  & answer_shape(5), &
17700 
17701  & answer_shape(6) ) &
17702  & )
17703 
17704  allocate( answer_negative( &
17705  & answer_shape(1), &
17706 
17707  & answer_shape(2), &
17708 
17709  & answer_shape(3), &
17710 
17711  & answer_shape(4), &
17712 
17713  & answer_shape(5), &
17714 
17715  & answer_shape(6) ) &
17716  & )
17717 
17718  allocate( check_negative( &
17719  & answer_shape(1), &
17720 
17721  & answer_shape(2), &
17722 
17723  & answer_shape(3), &
17724 
17725  & answer_shape(4), &
17726 
17727  & answer_shape(5), &
17728 
17729  & answer_shape(6) ) &
17730  & )
17731 
17732  allocate( both_negative( &
17733  & answer_shape(1), &
17734 
17735  & answer_shape(2), &
17736 
17737  & answer_shape(3), &
17738 
17739  & answer_shape(4), &
17740 
17741  & answer_shape(5), &
17742 
17743  & answer_shape(6) ) &
17744  & )
17745 
17746  answer_negative = answer < 0.0_dp
17747  check_negative = check < 0.0_dp
17748  both_negative = answer_negative .and. check_negative
17749  if (.not. negative_support_on) both_negative = .false.
17750 
17751  judge = answer > check
17752  where (both_negative) judge = .not. judge
17753 
17754  judge_rev = .not. judge
17755  err_flag = any(judge_rev)
17756  mask_array = 1
17757  pos = maxloc(mask_array, judge_rev)
17758 
17759  if (err_flag) then
17760 
17761  wrong = check( &
17762  & pos(1), &
17763 
17764  & pos(2), &
17765 
17766  & pos(3), &
17767 
17768  & pos(4), &
17769 
17770  & pos(5), &
17771 
17772  & pos(6) )
17773 
17774  right = answer( &
17775  & pos(1), &
17776 
17777  & pos(2), &
17778 
17779  & pos(3), &
17780 
17781  & pos(4), &
17782 
17783  & pos(5), &
17784 
17785  & pos(6) )
17786 
17787  write(unit=pos_array(1), fmt="(i20)") pos(1)
17788 
17789  write(unit=pos_array(2), fmt="(i20)") pos(2)
17790 
17791  write(unit=pos_array(3), fmt="(i20)") pos(3)
17792 
17793  write(unit=pos_array(4), fmt="(i20)") pos(4)
17794 
17795  write(unit=pos_array(5), fmt="(i20)") pos(5)
17796 
17797  write(unit=pos_array(6), fmt="(i20)") pos(6)
17798 
17799 
17800  pos_str = '(' // &
17801  & trim(adjustl(pos_array(1))) // ',' // &
17802 
17803  & trim(adjustl(pos_array(2))) // ',' // &
17804 
17805  & trim(adjustl(pos_array(3))) // ',' // &
17806 
17807  & trim(adjustl(pos_array(4))) // ',' // &
17808 
17809  & trim(adjustl(pos_array(5))) // ',' // &
17810 
17811  & trim(adjustl(pos_array(6))) // ')'
17812 
17813  if ( both_negative( &
17814  & pos(1), &
17815 
17816  & pos(2), &
17817 
17818  & pos(3), &
17819 
17820  & pos(4), &
17821 
17822  & pos(5), &
17823 
17824  & pos(6) ) ) then
17825 
17826  abs_mes = 'ABSOLUTE value of'
17827  else
17828  abs_mes = ''
17829 
17830  end if
17831 
17832  end if
17833  deallocate(mask_array, judge, judge_rev)
17834  deallocate(answer_negative, check_negative, both_negative)
17835 
17836 
17837 
17838 
17839  if (err_flag) then
17840  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17841  write(*,*) ''
17842  write(*,*) ' ' // trim(abs_mes) // &
17843  & ' check' // trim(pos_str) // ' = ', wrong
17844  write(*,*) ' is NOT LESS THAN'
17845  write(*,*) ' ' // trim(abs_mes) // &
17846  & ' answer' // trim(pos_str) // ' = ', right
17847 
17848  call abortprogram('')
17849  else
17850  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17851  end if
17852 
17853 
17854  end subroutine dctestassertlessthandouble6
17855 
17856 
17857  subroutine dctestassertlessthandouble7( &
17858  & message, answer, check, negative_support)
17859  use sysdep, only: abortprogram
17860  use dc_types, only: string, token
17861  implicit none
17862  character(*), intent(in):: message
17863  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
17864  real(DP), intent(in):: check(:,:,:,:,:,:,:)
17865  logical, intent(in), optional:: negative_support
17866  logical:: err_flag
17867  logical:: negative_support_on
17868  character(STRING):: pos_str
17869  character(TOKEN):: abs_mes
17870  real(DP):: wrong, right
17871 
17872  integer:: answer_shape(7), check_shape(7), pos(7)
17873  logical:: consist_shape(7)
17874  character(TOKEN):: pos_array(7)
17875  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
17876  logical, allocatable:: judge(:,:,:,:,:,:,:)
17877  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
17878  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
17879  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
17880  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
17881 
17882 
17883  continue
17884  if (present(negative_support)) then
17885  negative_support_on = negative_support
17886  else
17887  negative_support_on = .true.
17888  end if
17889 
17890  err_flag = .false.
17891 
17892 
17893  answer_shape = shape(answer)
17894  check_shape = shape(check)
17895 
17896  consist_shape = answer_shape == check_shape
17897 
17898  if (.not. all(consist_shape)) then
17899  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17900  write(*,*) ''
17901  write(*,*) ' shape of check is (', check_shape, ')'
17902  write(*,*) ' is INCORRECT'
17903  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17904 
17905  call abortprogram('')
17906  end if
17907 
17908 
17909  allocate( mask_array( &
17910  & answer_shape(1), &
17911 
17912  & answer_shape(2), &
17913 
17914  & answer_shape(3), &
17915 
17916  & answer_shape(4), &
17917 
17918  & answer_shape(5), &
17919 
17920  & answer_shape(6), &
17921 
17922  & answer_shape(7) ) &
17923  & )
17924 
17925  allocate( judge( &
17926  & answer_shape(1), &
17927 
17928  & answer_shape(2), &
17929 
17930  & answer_shape(3), &
17931 
17932  & answer_shape(4), &
17933 
17934  & answer_shape(5), &
17935 
17936  & answer_shape(6), &
17937 
17938  & answer_shape(7) ) &
17939  & )
17940 
17941  allocate( judge_rev( &
17942  & answer_shape(1), &
17943 
17944  & answer_shape(2), &
17945 
17946  & answer_shape(3), &
17947 
17948  & answer_shape(4), &
17949 
17950  & answer_shape(5), &
17951 
17952  & answer_shape(6), &
17953 
17954  & answer_shape(7) ) &
17955  & )
17956 
17957  allocate( answer_negative( &
17958  & answer_shape(1), &
17959 
17960  & answer_shape(2), &
17961 
17962  & answer_shape(3), &
17963 
17964  & answer_shape(4), &
17965 
17966  & answer_shape(5), &
17967 
17968  & answer_shape(6), &
17969 
17970  & answer_shape(7) ) &
17971  & )
17972 
17973  allocate( check_negative( &
17974  & answer_shape(1), &
17975 
17976  & answer_shape(2), &
17977 
17978  & answer_shape(3), &
17979 
17980  & answer_shape(4), &
17981 
17982  & answer_shape(5), &
17983 
17984  & answer_shape(6), &
17985 
17986  & answer_shape(7) ) &
17987  & )
17988 
17989  allocate( both_negative( &
17990  & answer_shape(1), &
17991 
17992  & answer_shape(2), &
17993 
17994  & answer_shape(3), &
17995 
17996  & answer_shape(4), &
17997 
17998  & answer_shape(5), &
17999 
18000  & answer_shape(6), &
18001 
18002  & answer_shape(7) ) &
18003  & )
18004 
18005  answer_negative = answer < 0.0_dp
18006  check_negative = check < 0.0_dp
18007  both_negative = answer_negative .and. check_negative
18008  if (.not. negative_support_on) both_negative = .false.
18009 
18010  judge = answer > check
18011  where (both_negative) judge = .not. judge
18012 
18013  judge_rev = .not. judge
18014  err_flag = any(judge_rev)
18015  mask_array = 1
18016  pos = maxloc(mask_array, judge_rev)
18017 
18018  if (err_flag) then
18019 
18020  wrong = check( &
18021  & pos(1), &
18022 
18023  & pos(2), &
18024 
18025  & pos(3), &
18026 
18027  & pos(4), &
18028 
18029  & pos(5), &
18030 
18031  & pos(6), &
18032 
18033  & pos(7) )
18034 
18035  right = answer( &
18036  & pos(1), &
18037 
18038  & pos(2), &
18039 
18040  & pos(3), &
18041 
18042  & pos(4), &
18043 
18044  & pos(5), &
18045 
18046  & pos(6), &
18047 
18048  & pos(7) )
18049 
18050  write(unit=pos_array(1), fmt="(i20)") pos(1)
18051 
18052  write(unit=pos_array(2), fmt="(i20)") pos(2)
18053 
18054  write(unit=pos_array(3), fmt="(i20)") pos(3)
18055 
18056  write(unit=pos_array(4), fmt="(i20)") pos(4)
18057 
18058  write(unit=pos_array(5), fmt="(i20)") pos(5)
18059 
18060  write(unit=pos_array(6), fmt="(i20)") pos(6)
18061 
18062  write(unit=pos_array(7), fmt="(i20)") pos(7)
18063 
18064 
18065  pos_str = '(' // &
18066  & trim(adjustl(pos_array(1))) // ',' // &
18067 
18068  & trim(adjustl(pos_array(2))) // ',' // &
18069 
18070  & trim(adjustl(pos_array(3))) // ',' // &
18071 
18072  & trim(adjustl(pos_array(4))) // ',' // &
18073 
18074  & trim(adjustl(pos_array(5))) // ',' // &
18075 
18076  & trim(adjustl(pos_array(6))) // ',' // &
18077 
18078  & trim(adjustl(pos_array(7))) // ')'
18079 
18080  if ( both_negative( &
18081  & pos(1), &
18082 
18083  & pos(2), &
18084 
18085  & pos(3), &
18086 
18087  & pos(4), &
18088 
18089  & pos(5), &
18090 
18091  & pos(6), &
18092 
18093  & pos(7) ) ) then
18094 
18095  abs_mes = 'ABSOLUTE value of'
18096  else
18097  abs_mes = ''
18098 
18099  end if
18100 
18101  end if
18102  deallocate(mask_array, judge, judge_rev)
18103  deallocate(answer_negative, check_negative, both_negative)
18104 
18105 
18106 
18107 
18108  if (err_flag) then
18109  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
18110  write(*,*) ''
18111  write(*,*) ' ' // trim(abs_mes) // &
18112  & ' check' // trim(pos_str) // ' = ', wrong
18113  write(*,*) ' is NOT LESS THAN'
18114  write(*,*) ' ' // trim(abs_mes) // &
18115  & ' answer' // trim(pos_str) // ' = ', right
18116 
18117  call abortprogram('')
18118  else
18119  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
18120  end if
18121 
18122 
18123  end subroutine dctestassertlessthandouble7
18124 
18125 end module dc_test
18126 
18127 !--
18128 ! vi:set readonly sw=4 ts=8:
18129 !
18130 !Local Variables:
18131 !mode: f90
18132 !buffer-read-only: t
18133 !End:
18134 !
18135 !++
dc_test
Definition: dc_test.f90:29
dc_test::dctestassertgreaterthandouble1
subroutine dctestassertgreaterthandouble1(message, answer, check, negative_support)
Definition: dc_test.f90:12209
dc_test::dctestassertequalint6
subroutine dctestassertequalint6(message, answer, check)
Definition: dc_test.f90:2443
dc_test::dctestassertgreaterthanreal0
subroutine dctestassertgreaterthanreal0(message, answer, check, negative_support)
Definition: dc_test.f90:10652
dc_test::dctestassertequaldouble7digits
subroutine dctestassertequaldouble7digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:8829
dc_test::dctestassertlessthanint1
subroutine dctestassertlessthanint1(message, answer, check, negative_support)
Definition: dc_test.f90:13705
dc_test::dctestassertequalint7
subroutine dctestassertequalint7(message, answer, check)
Definition: dc_test.f90:2612
dc_test::dctestassertequaldouble3
subroutine dctestassertequaldouble3(message, answer, check)
Definition: dc_test.f90:4092
dc_test::dctestassertlessthanint5
subroutine dctestassertlessthanint5(message, answer, check, negative_support)
Definition: dc_test.f90:14395
dc_test::dctestassertequaldouble7
subroutine dctestassertequaldouble7(message, answer, check)
Definition: dc_test.f90:4684
dc_test::dctestassertequalreal1
subroutine dctestassertequalreal1(message, answer, check)
Definition: dc_test.f90:2838
dc_test::dctestassertequaldouble1digits
subroutine dctestassertequaldouble1digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:7389
dc_test::dctestassertequalchar1
subroutine dctestassertequalchar1(message, answer, check)
Definition: dc_test.f90:575
dc_test::dctestassertequallogical7
subroutine dctestassertequallogical7(message, answer, check)
Definition: dc_test.f90:5346
dc_test::assertequal
Definition: dc_test.f90:295
dc_test::dctestassertequaldouble4
subroutine dctestassertequaldouble4(message, answer, check)
Definition: dc_test.f90:4219
dc_test::dctestassertequalchar4
subroutine dctestassertequalchar4(message, answer, check)
Definition: dc_test.f90:979
dc_test::dctestassertequallogical4
subroutine dctestassertequallogical4(message, answer, check)
Definition: dc_test.f90:5106
dc_test::dctestassertequalreal3
subroutine dctestassertequalreal3(message, answer, check)
Definition: dc_test.f90:3056
dc_test::dctestassertlessthanreal0
subroutine dctestassertlessthanreal0(message, answer, check, negative_support)
Definition: dc_test.f90:15136
dc_test::dctestassertlessthandouble0
subroutine dctestassertlessthandouble0(message, answer, check, negative_support)
Definition: dc_test.f90:16632
dc_test::dctestassertequalreal5digits
subroutine dctestassertequalreal5digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:6388
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_test::dctestassertequalreal7
subroutine dctestassertequalreal7(message, answer, check)
Definition: dc_test.f90:3648
dc_test::dctestassertgreaterthanint1
subroutine dctestassertgreaterthanint1(message, answer, check, negative_support)
Definition: dc_test.f90:9221
dc_test::dctestassertequaldouble0digits
subroutine dctestassertequaldouble0digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:7297
dc_test::dctestassertequalint2
subroutine dctestassertequalint2(message, answer, check)
Definition: dc_test.f90:1907
dc_test::dctestassertlessthanint7
subroutine dctestassertlessthanint7(message, answer, check, negative_support)
Definition: dc_test.f90:14867
dc_test::dctestassertequalchar5
subroutine dctestassertequalchar5(message, answer, check)
Definition: dc_test.f90:1147
dc_test::dctestassertequalreal2digits
subroutine dctestassertequalreal2digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:5713
dc_test::dctestassertlessthandouble1
subroutine dctestassertlessthandouble1(message, answer, check, negative_support)
Definition: dc_test.f90:16697
dc_test::dctestassertequallogical3
subroutine dctestassertequallogical3(message, answer, check)
Definition: dc_test.f90:5034
dc_test::dctestassertequallogical0
subroutine dctestassertequallogical0(message, answer, check)
Definition: dc_test.f90:4866
dc_test::dctestassertequalreal3digits
subroutine dctestassertequalreal3digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:5912
dc_test::dctestassertequallogical1
subroutine dctestassertequallogical1(message, answer, check)
Definition: dc_test.f90:4900
dc_test::dctestassertequalint1
subroutine dctestassertequalint1(message, answer, check)
Definition: dc_test.f90:1802
dc_test::dctestassertgreaterthanreal2
subroutine dctestassertgreaterthanreal2(message, answer, check, negative_support)
Definition: dc_test.f90:10862
dc_test::dctestassertgreaterthanint6
subroutine dctestassertgreaterthanint6(message, answer, check, negative_support)
Definition: dc_test.f90:10136
dc_test::dctestassertgreaterthanreal7
subroutine dctestassertgreaterthanreal7(message, answer, check, negative_support)
Definition: dc_test.f90:11877
dc_test::dctestassertequalreal5
subroutine dctestassertequalreal5(message, answer, check)
Definition: dc_test.f90:3324
dc_test::dctestassertlessthanreal2
subroutine dctestassertlessthanreal2(message, answer, check, negative_support)
Definition: dc_test.f90:15348
dc_test::dctestassertgreaterthandouble4
subroutine dctestassertgreaterthandouble4(message, answer, check, negative_support)
Definition: dc_test.f90:12696
dc_test::dctestassertlessthanint4
subroutine dctestassertlessthanint4(message, answer, check, negative_support)
Definition: dc_test.f90:14192
dc_test::dctestassertequaldouble1
subroutine dctestassertequaldouble1(message, answer, check)
Definition: dc_test.f90:3874
dc_test::dctestassertlessthanint2
subroutine dctestassertlessthanint2(message, answer, check, negative_support)
Definition: dc_test.f90:13852
dc_test::dctestassertequaldouble2
subroutine dctestassertequaldouble2(message, answer, check)
Definition: dc_test.f90:3979
dc_test::dctestassertgreaterthanint3
subroutine dctestassertgreaterthanint3(message, answer, check, negative_support)
Definition: dc_test.f90:9527
dc_test::dctestassertgreaterthanint0
subroutine dctestassertgreaterthanint0(message, answer, check, negative_support)
Definition: dc_test.f90:9158
dc_test::dctestassertequallogical2
subroutine dctestassertequallogical2(message, answer, check)
Definition: dc_test.f90:4966
dc_test::dctestassertequaldouble6
subroutine dctestassertequaldouble6(message, answer, check)
Definition: dc_test.f90:4515
dc_test::dctestassertgreaterthanint4
subroutine dctestassertgreaterthanint4(message, answer, check, negative_support)
Definition: dc_test.f90:9708
dc_test::dctestassertlessthandouble2
subroutine dctestassertlessthandouble2(message, answer, check, negative_support)
Definition: dc_test.f90:16844
dc_test::dctestassertgreaterthandouble7
subroutine dctestassertgreaterthandouble7(message, answer, check, negative_support)
Definition: dc_test.f90:13371
dc_test::dctestassertlessthanreal5
subroutine dctestassertlessthanreal5(message, answer, check, negative_support)
Definition: dc_test.f90:15891
dc_test::dctestassertequaldouble2digits
subroutine dctestassertequaldouble2digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:7574
dc_test::dctestassertequalreal6
subroutine dctestassertequalreal6(message, answer, check)
Definition: dc_test.f90:3479
dc_test::dctestassertequaldouble6digits
subroutine dctestassertequaldouble6digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:8526
dc_test::dctestassertequalint3
subroutine dctestassertequalint3(message, answer, check)
Definition: dc_test.f90:2020
dc_types::dp
integer, parameter, public dp
倍精度実数型変数
Definition: dc_types.f90:83
dc_test::dctestassertequalint0
subroutine dctestassertequalint0(message, answer, check)
Definition: dc_test.f90:1759
dc_test::dctestassertgreaterthanint2
subroutine dctestassertgreaterthanint2(message, answer, check, negative_support)
Definition: dc_test.f90:9368
dc_test::dctestassertequaldouble5
subroutine dctestassertequaldouble5(message, answer, check)
Definition: dc_test.f90:4360
dc_test::dctestassertequaldouble3digits
subroutine dctestassertequaldouble3digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:7773
dc_test::dctestassertequaldouble0
subroutine dctestassertequaldouble0(message, answer, check)
Definition: dc_test.f90:3831
dc_test::dctestassertequallogical5
subroutine dctestassertequallogical5(message, answer, check)
Definition: dc_test.f90:5182
dc_test::dctestassertgreaterthandouble0
subroutine dctestassertgreaterthandouble0(message, answer, check, negative_support)
Definition: dc_test.f90:12146
dc_test::dctestassertlessthanreal1
subroutine dctestassertlessthanreal1(message, answer, check, negative_support)
Definition: dc_test.f90:15201
dc_test::dctestassertlessthandouble3
subroutine dctestassertlessthandouble3(message, answer, check, negative_support)
Definition: dc_test.f90:17003
dc_test::dctestassertgreaterthanreal3
subroutine dctestassertgreaterthanreal3(message, answer, check, negative_support)
Definition: dc_test.f90:11021
dc_test::dctestassertequalint4
subroutine dctestassertequalint4(message, answer, check)
Definition: dc_test.f90:2147
dc_test::dctestassertequaldouble4digits
subroutine dctestassertequaldouble4digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:7998
dc_test::dctestassertequalchar7
subroutine dctestassertequalchar7(message, answer, check)
Definition: dc_test.f90:1537
dc_test::dctestassertgreaterthanreal4
subroutine dctestassertgreaterthanreal4(message, answer, check, negative_support)
Definition: dc_test.f90:11202
dc_test::dctestassertlessthanreal4
subroutine dctestassertlessthanreal4(message, answer, check, negative_support)
Definition: dc_test.f90:15688
dc_test::dctestassertgreaterthandouble3
subroutine dctestassertgreaterthandouble3(message, answer, check, negative_support)
Definition: dc_test.f90:12515
dc_test::dctestassertlessthandouble7
subroutine dctestassertlessthandouble7(message, answer, check, negative_support)
Definition: dc_test.f90:17859
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_test::dctestassertequallogical6
subroutine dctestassertequallogical6(message, answer, check)
Definition: dc_test.f90:5262
dc_test::dctestassertlessthanreal3
subroutine dctestassertlessthanreal3(message, answer, check, negative_support)
Definition: dc_test.f90:15507
dc_test::dctestassertgreaterthanint7
subroutine dctestassertgreaterthanint7(message, answer, check, negative_support)
Definition: dc_test.f90:10383
dc_test::dctestassertlessthanint0
subroutine dctestassertlessthanint0(message, answer, check, negative_support)
Definition: dc_test.f90:13640
dc_test::dctestassertlessthandouble5
subroutine dctestassertlessthandouble5(message, answer, check, negative_support)
Definition: dc_test.f90:17387
dc_test::dctestassertgreaterthanreal5
subroutine dctestassertgreaterthanreal5(message, answer, check, negative_support)
Definition: dc_test.f90:11405
dc_test::dctestassertlessthandouble6
subroutine dctestassertlessthandouble6(message, answer, check, negative_support)
Definition: dc_test.f90:17612
dc_test::assertgreaterthan
Definition: dc_test.f90:419
dc_test::dctestassertequalreal2
subroutine dctestassertequalreal2(message, answer, check)
Definition: dc_test.f90:2943
dc_test::dctestassertequalreal4digits
subroutine dctestassertequalreal4digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:6137
dc_test::dctestassertlessthanreal7
subroutine dctestassertlessthanreal7(message, answer, check, negative_support)
Definition: dc_test.f90:16363
dc_test::dctestassertgreaterthandouble2
subroutine dctestassertgreaterthandouble2(message, answer, check, negative_support)
Definition: dc_test.f90:12356
dc_test::dctestassertgreaterthanreal6
subroutine dctestassertgreaterthanreal6(message, answer, check, negative_support)
Definition: dc_test.f90:11630
dc_test::dctestassertequalreal6digits
subroutine dctestassertequalreal6digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:6665
dc_test::dctestassertequaldouble5digits
subroutine dctestassertequaldouble5digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:8249
dc_test::dctestassertequalreal4
subroutine dctestassertequalreal4(message, answer, check)
Definition: dc_test.f90:3183
dc_test::dctestassertgreaterthandouble6
subroutine dctestassertgreaterthandouble6(message, answer, check, negative_support)
Definition: dc_test.f90:13124
dc_test::dctestassertlessthandouble4
subroutine dctestassertlessthandouble4(message, answer, check, negative_support)
Definition: dc_test.f90:17184
dc_test::dctestassertequalchar3
subroutine dctestassertequalchar3(message, answer, check)
Definition: dc_test.f90:829
dc_test::dctestassertlessthanint3
subroutine dctestassertlessthanint3(message, answer, check, negative_support)
Definition: dc_test.f90:14011
dc_test::dctestassertlessthanreal6
subroutine dctestassertlessthanreal6(message, answer, check, negative_support)
Definition: dc_test.f90:16116
dc_test::dctestassertequalint5
subroutine dctestassertequalint5(message, answer, check)
Definition: dc_test.f90:2288
dc_test::dctestassertequalreal1digits
subroutine dctestassertequalreal1digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:5528
dc_test::dctestassertequalreal7digits
subroutine dctestassertequalreal7digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:6968
dc_test::dctestassertequalreal0
subroutine dctestassertequalreal0(message, answer, check)
Definition: dc_test.f90:2795
dc_test::assertlessthan
Definition: dc_test.f90:473
dc_test::dctestassertequalreal0digits
subroutine dctestassertequalreal0digits(message, answer, check, significant_digits, ignore_digits)
Definition: dc_test.f90:5436
dc_test::dctestassertgreaterthandouble5
subroutine dctestassertgreaterthandouble5(message, answer, check, negative_support)
Definition: dc_test.f90:12899
dc_test::dctestassertequalchar2
subroutine dctestassertequalchar2(message, answer, check)
Definition: dc_test.f90:697
dc_test::dctestassertequalchar6
subroutine dctestassertequalchar6(message, answer, check)
Definition: dc_test.f90:1333
dc_test::dctestassertgreaterthanreal1
subroutine dctestassertgreaterthanreal1(message, answer, check, negative_support)
Definition: dc_test.f90:10715
dc_test::dctestassertgreaterthanint5
subroutine dctestassertgreaterthanint5(message, answer, check, negative_support)
Definition: dc_test.f90:9911
dc_test::dctestassertequalchar0
subroutine dctestassertequalchar0(message, answer, check)
Definition: dc_test.f90:531
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118
dc_test::dctestassertlessthanint6
subroutine dctestassertlessthanint6(message, answer, check, negative_support)
Definition: dc_test.f90:14620