gtool5 Fortran 90/95 Library 1.0.0-rc5
日本語
Loading...
Searching...
No Matches
Public Member Functions | List of all members
dc_test::assertgreaterthan Interface Reference

Public Member Functions

subroutine dctestassertgreaterthanint0 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint1 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint2 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint3 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint4 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint5 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint6 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint7 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal0 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal1 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal2 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal3 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal4 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal5 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal6 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal7 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble0 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble1 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble2 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble3 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble4 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble5 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble6 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble7 (message, answer, check, negative_support)
 

Detailed Description

Definition at line 284 of file dc_test.f90.

Member Function/Subroutine Documentation

◆ dctestassertgreaterthandouble0()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble0 ( character(*), intent(in)  message,
real(dp), intent(in)  answer,
real(dp), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12034 of file dc_test.f90.

12036 use sysdep, only: abortprogram
12037 use dc_types, only: string, token
12038 implicit none
12039 character(*), intent(in):: message
12040 real(DP), intent(in):: answer
12041 real(DP), intent(in):: check
12042 logical, intent(in), optional:: negative_support
12043 logical:: err_flag
12044 logical:: negative_support_on
12045 character(STRING):: pos_str
12046 character(TOKEN):: abs_mes
12047 real(DP):: wrong, right
12048
12049
12050
12051 continue
12052 if (present(negative_support)) then
12053 negative_support_on = negative_support
12054 else
12055 negative_support_on = .true.
12056 end if
12057
12058 err_flag = .false.
12059
12060
12061 err_flag = .not. answer < check
12062 abs_mes = ''
12063
12064 if ( answer < 0.0_dp &
12065 & .and. check < 0.0_dp &
12066 & .and. negative_support_on ) then
12067
12068 err_flag = .not. err_flag
12069 abs_mes = 'ABSOLUTE value of'
12070 end if
12071
12072 wrong = check
12073 right = answer
12074 pos_str = ''
12075
12076
12077
12078
12079 if (err_flag) then
12080 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12081 write(*,*) ''
12082 write(*,*) ' ' // trim(abs_mes) // &
12083 & ' check' // trim(pos_str) // ' = ', wrong
12084 write(*,*) ' is NOT GREATER THAN'
12085 write(*,*) ' ' // trim(abs_mes) // &
12086 & ' answer' // trim(pos_str) // ' = ', right
12087
12088 call abortprogram('')
12089 else
12090 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12091 end if
12092
12093
dc_types
Provides kind type parameter values.
Definition dc_types.f90:55
dc_types::token
integer, parameter, public token
Character length for word, token
Definition dc_types.f90:128
dc_types::string
integer, parameter, public string
Character length for string
Definition dc_types.f90:137
sysdep
Provides interface for system dependent procedures.
Definition sysdep.f90:54
sysdep::abortprogram
subroutine, public abortprogram(message)
Abort program execution.
Definition sysdep.f90:90

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthandouble1()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble1 ( character(*), intent(in)  message,
real(dp), dimension(:), intent(in)  answer,
real(dp), dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12097 of file dc_test.f90.

12099 use sysdep, only: abortprogram
12100 use dc_types, only: string, token
12101 implicit none
12102 character(*), intent(in):: message
12103 real(DP), intent(in):: answer(:)
12104 real(DP), intent(in):: check(:)
12105 logical, intent(in), optional:: negative_support
12106 logical:: err_flag
12107 logical:: negative_support_on
12108 character(STRING):: pos_str
12109 character(TOKEN):: abs_mes
12110 real(DP):: wrong, right
12111
12112 integer:: answer_shape(1), check_shape(1), pos(1)
12113 logical:: consist_shape(1)
12114 character(TOKEN):: pos_array(1)
12115 integer, allocatable:: mask_array(:)
12116 logical, allocatable:: judge(:)
12117 logical, allocatable:: judge_rev(:)
12118 logical, allocatable:: answer_negative(:)
12119 logical, allocatable:: check_negative(:)
12120 logical, allocatable:: both_negative(:)
12121
12122
12123 continue
12124 if (present(negative_support)) then
12125 negative_support_on = negative_support
12126 else
12127 negative_support_on = .true.
12128 end if
12129
12130 err_flag = .false.
12131
12132
12133 answer_shape = shape(answer)
12134 check_shape = shape(check)
12135
12136 consist_shape = answer_shape == check_shape
12137
12138 if (.not. all(consist_shape)) then
12139 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12140 write(*,*) ''
12141 write(*,*) ' shape of check is (', check_shape, ')'
12142 write(*,*) ' is INCORRECT'
12143 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12144
12145 call abortprogram('')
12146 end if
12147
12148
12149 allocate( mask_array( &
12150
12151 & answer_shape(1) ) &
12152 & )
12153
12154 allocate( judge( &
12155
12156 & answer_shape(1) ) &
12157 & )
12158
12159 allocate( judge_rev( &
12160
12161 & answer_shape(1) ) &
12162 & )
12163
12164 allocate( answer_negative( &
12165
12166 & answer_shape(1) ) &
12167 & )
12168
12169 allocate( check_negative( &
12170
12171 & answer_shape(1) ) &
12172 & )
12173
12174 allocate( both_negative( &
12175
12176 & answer_shape(1) ) &
12177 & )
12178
12179 answer_negative = answer < 0.0_dp
12180 check_negative = check < 0.0_dp
12181 both_negative = answer_negative .and. check_negative
12182 if (.not. negative_support_on) both_negative = .false.
12183
12184 judge = answer < check
12185 where (both_negative) judge = .not. judge
12186
12187 judge_rev = .not. judge
12188 err_flag = any(judge_rev)
12189 mask_array = 1
12190 pos = maxloc(mask_array, judge_rev)
12191
12192 if (err_flag) then
12193
12194 wrong = check( &
12195
12196 & pos(1) )
12197
12198 right = answer( &
12199
12200 & pos(1) )
12201
12202 write(unit=pos_array(1), fmt="(i20)") pos(1)
12203
12204
12205 pos_str = '(' // &
12206
12207 & trim(adjustl(pos_array(1))) // ')'
12208
12209 if ( both_negative( &
12210
12211 & pos(1) ) ) then
12212
12213 abs_mes = 'ABSOLUTE value of'
12214 else
12215 abs_mes = ''
12216
12217 end if
12218
12219 end if
12220 deallocate(mask_array, judge, judge_rev)
12221 deallocate(answer_negative, check_negative, both_negative)
12222
12223
12224
12225
12226 if (err_flag) then
12227 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12228 write(*,*) ''
12229 write(*,*) ' ' // trim(abs_mes) // &
12230 & ' check' // trim(pos_str) // ' = ', wrong
12231 write(*,*) ' is NOT GREATER THAN'
12232 write(*,*) ' ' // trim(abs_mes) // &
12233 & ' answer' // trim(pos_str) // ' = ', right
12234
12235 call abortprogram('')
12236 else
12237 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12238 end if
12239
12240

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthandouble2()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble2 ( character(*), intent(in)  message,
real(dp), dimension(:,:), intent(in)  answer,
real(dp), dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12244 of file dc_test.f90.

12246 use sysdep, only: abortprogram
12247 use dc_types, only: string, token
12248 implicit none
12249 character(*), intent(in):: message
12250 real(DP), intent(in):: answer(:,:)
12251 real(DP), intent(in):: check(:,:)
12252 logical, intent(in), optional:: negative_support
12253 logical:: err_flag
12254 logical:: negative_support_on
12255 character(STRING):: pos_str
12256 character(TOKEN):: abs_mes
12257 real(DP):: wrong, right
12258
12259 integer:: answer_shape(2), check_shape(2), pos(2)
12260 logical:: consist_shape(2)
12261 character(TOKEN):: pos_array(2)
12262 integer, allocatable:: mask_array(:,:)
12263 logical, allocatable:: judge(:,:)
12264 logical, allocatable:: judge_rev(:,:)
12265 logical, allocatable:: answer_negative(:,:)
12266 logical, allocatable:: check_negative(:,:)
12267 logical, allocatable:: both_negative(:,:)
12268
12269
12270 continue
12271 if (present(negative_support)) then
12272 negative_support_on = negative_support
12273 else
12274 negative_support_on = .true.
12275 end if
12276
12277 err_flag = .false.
12278
12279
12280 answer_shape = shape(answer)
12281 check_shape = shape(check)
12282
12283 consist_shape = answer_shape == check_shape
12284
12285 if (.not. all(consist_shape)) then
12286 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12287 write(*,*) ''
12288 write(*,*) ' shape of check is (', check_shape, ')'
12289 write(*,*) ' is INCORRECT'
12290 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12291
12292 call abortprogram('')
12293 end if
12294
12295
12296 allocate( mask_array( &
12297 & answer_shape(1), &
12298
12299 & answer_shape(2) ) &
12300 & )
12301
12302 allocate( judge( &
12303 & answer_shape(1), &
12304
12305 & answer_shape(2) ) &
12306 & )
12307
12308 allocate( judge_rev( &
12309 & answer_shape(1), &
12310
12311 & answer_shape(2) ) &
12312 & )
12313
12314 allocate( answer_negative( &
12315 & answer_shape(1), &
12316
12317 & answer_shape(2) ) &
12318 & )
12319
12320 allocate( check_negative( &
12321 & answer_shape(1), &
12322
12323 & answer_shape(2) ) &
12324 & )
12325
12326 allocate( both_negative( &
12327 & answer_shape(1), &
12328
12329 & answer_shape(2) ) &
12330 & )
12331
12332 answer_negative = answer < 0.0_dp
12333 check_negative = check < 0.0_dp
12334 both_negative = answer_negative .and. check_negative
12335 if (.not. negative_support_on) both_negative = .false.
12336
12337 judge = answer < check
12338 where (both_negative) judge = .not. judge
12339
12340 judge_rev = .not. judge
12341 err_flag = any(judge_rev)
12342 mask_array = 1
12343 pos = maxloc(mask_array, judge_rev)
12344
12345 if (err_flag) then
12346
12347 wrong = check( &
12348 & pos(1), &
12349
12350 & pos(2) )
12351
12352 right = answer( &
12353 & pos(1), &
12354
12355 & pos(2) )
12356
12357 write(unit=pos_array(1), fmt="(i20)") pos(1)
12358
12359 write(unit=pos_array(2), fmt="(i20)") pos(2)
12360
12361
12362 pos_str = '(' // &
12363 & trim(adjustl(pos_array(1))) // ',' // &
12364
12365 & trim(adjustl(pos_array(2))) // ')'
12366
12367 if ( both_negative( &
12368 & pos(1), &
12369
12370 & pos(2) ) ) then
12371
12372 abs_mes = 'ABSOLUTE value of'
12373 else
12374 abs_mes = ''
12375
12376 end if
12377
12378 end if
12379 deallocate(mask_array, judge, judge_rev)
12380 deallocate(answer_negative, check_negative, both_negative)
12381
12382
12383
12384
12385 if (err_flag) then
12386 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12387 write(*,*) ''
12388 write(*,*) ' ' // trim(abs_mes) // &
12389 & ' check' // trim(pos_str) // ' = ', wrong
12390 write(*,*) ' is NOT GREATER THAN'
12391 write(*,*) ' ' // trim(abs_mes) // &
12392 & ' answer' // trim(pos_str) // ' = ', right
12393
12394 call abortprogram('')
12395 else
12396 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12397 end if
12398
12399

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthandouble3()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble3 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12403 of file dc_test.f90.

12405 use sysdep, only: abortprogram
12406 use dc_types, only: string, token
12407 implicit none
12408 character(*), intent(in):: message
12409 real(DP), intent(in):: answer(:,:,:)
12410 real(DP), intent(in):: check(:,:,:)
12411 logical, intent(in), optional:: negative_support
12412 logical:: err_flag
12413 logical:: negative_support_on
12414 character(STRING):: pos_str
12415 character(TOKEN):: abs_mes
12416 real(DP):: wrong, right
12417
12418 integer:: answer_shape(3), check_shape(3), pos(3)
12419 logical:: consist_shape(3)
12420 character(TOKEN):: pos_array(3)
12421 integer, allocatable:: mask_array(:,:,:)
12422 logical, allocatable:: judge(:,:,:)
12423 logical, allocatable:: judge_rev(:,:,:)
12424 logical, allocatable:: answer_negative(:,:,:)
12425 logical, allocatable:: check_negative(:,:,:)
12426 logical, allocatable:: both_negative(:,:,:)
12427
12428
12429 continue
12430 if (present(negative_support)) then
12431 negative_support_on = negative_support
12432 else
12433 negative_support_on = .true.
12434 end if
12435
12436 err_flag = .false.
12437
12438
12439 answer_shape = shape(answer)
12440 check_shape = shape(check)
12441
12442 consist_shape = answer_shape == check_shape
12443
12444 if (.not. all(consist_shape)) then
12445 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12446 write(*,*) ''
12447 write(*,*) ' shape of check is (', check_shape, ')'
12448 write(*,*) ' is INCORRECT'
12449 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12450
12451 call abortprogram('')
12452 end if
12453
12454
12455 allocate( mask_array( &
12456 & answer_shape(1), &
12457
12458 & answer_shape(2), &
12459
12460 & answer_shape(3) ) &
12461 & )
12462
12463 allocate( judge( &
12464 & answer_shape(1), &
12465
12466 & answer_shape(2), &
12467
12468 & answer_shape(3) ) &
12469 & )
12470
12471 allocate( judge_rev( &
12472 & answer_shape(1), &
12473
12474 & answer_shape(2), &
12475
12476 & answer_shape(3) ) &
12477 & )
12478
12479 allocate( answer_negative( &
12480 & answer_shape(1), &
12481
12482 & answer_shape(2), &
12483
12484 & answer_shape(3) ) &
12485 & )
12486
12487 allocate( check_negative( &
12488 & answer_shape(1), &
12489
12490 & answer_shape(2), &
12491
12492 & answer_shape(3) ) &
12493 & )
12494
12495 allocate( both_negative( &
12496 & answer_shape(1), &
12497
12498 & answer_shape(2), &
12499
12500 & answer_shape(3) ) &
12501 & )
12502
12503 answer_negative = answer < 0.0_dp
12504 check_negative = check < 0.0_dp
12505 both_negative = answer_negative .and. check_negative
12506 if (.not. negative_support_on) both_negative = .false.
12507
12508 judge = answer < check
12509 where (both_negative) judge = .not. judge
12510
12511 judge_rev = .not. judge
12512 err_flag = any(judge_rev)
12513 mask_array = 1
12514 pos = maxloc(mask_array, judge_rev)
12515
12516 if (err_flag) then
12517
12518 wrong = check( &
12519 & pos(1), &
12520
12521 & pos(2), &
12522
12523 & pos(3) )
12524
12525 right = answer( &
12526 & pos(1), &
12527
12528 & pos(2), &
12529
12530 & pos(3) )
12531
12532 write(unit=pos_array(1), fmt="(i20)") pos(1)
12533
12534 write(unit=pos_array(2), fmt="(i20)") pos(2)
12535
12536 write(unit=pos_array(3), fmt="(i20)") pos(3)
12537
12538
12539 pos_str = '(' // &
12540 & trim(adjustl(pos_array(1))) // ',' // &
12541
12542 & trim(adjustl(pos_array(2))) // ',' // &
12543
12544 & trim(adjustl(pos_array(3))) // ')'
12545
12546 if ( both_negative( &
12547 & pos(1), &
12548
12549 & pos(2), &
12550
12551 & pos(3) ) ) then
12552
12553 abs_mes = 'ABSOLUTE value of'
12554 else
12555 abs_mes = ''
12556
12557 end if
12558
12559 end if
12560 deallocate(mask_array, judge, judge_rev)
12561 deallocate(answer_negative, check_negative, both_negative)
12562
12563
12564
12565
12566 if (err_flag) then
12567 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12568 write(*,*) ''
12569 write(*,*) ' ' // trim(abs_mes) // &
12570 & ' check' // trim(pos_str) // ' = ', wrong
12571 write(*,*) ' is NOT GREATER THAN'
12572 write(*,*) ' ' // trim(abs_mes) // &
12573 & ' answer' // trim(pos_str) // ' = ', right
12574
12575 call abortprogram('')
12576 else
12577 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12578 end if
12579
12580

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthandouble4()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble4 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12584 of file dc_test.f90.

12586 use sysdep, only: abortprogram
12587 use dc_types, only: string, token
12588 implicit none
12589 character(*), intent(in):: message
12590 real(DP), intent(in):: answer(:,:,:,:)
12591 real(DP), intent(in):: check(:,:,:,:)
12592 logical, intent(in), optional:: negative_support
12593 logical:: err_flag
12594 logical:: negative_support_on
12595 character(STRING):: pos_str
12596 character(TOKEN):: abs_mes
12597 real(DP):: wrong, right
12598
12599 integer:: answer_shape(4), check_shape(4), pos(4)
12600 logical:: consist_shape(4)
12601 character(TOKEN):: pos_array(4)
12602 integer, allocatable:: mask_array(:,:,:,:)
12603 logical, allocatable:: judge(:,:,:,:)
12604 logical, allocatable:: judge_rev(:,:,:,:)
12605 logical, allocatable:: answer_negative(:,:,:,:)
12606 logical, allocatable:: check_negative(:,:,:,:)
12607 logical, allocatable:: both_negative(:,:,:,:)
12608
12609
12610 continue
12611 if (present(negative_support)) then
12612 negative_support_on = negative_support
12613 else
12614 negative_support_on = .true.
12615 end if
12616
12617 err_flag = .false.
12618
12619
12620 answer_shape = shape(answer)
12621 check_shape = shape(check)
12622
12623 consist_shape = answer_shape == check_shape
12624
12625 if (.not. all(consist_shape)) then
12626 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12627 write(*,*) ''
12628 write(*,*) ' shape of check is (', check_shape, ')'
12629 write(*,*) ' is INCORRECT'
12630 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12631
12632 call abortprogram('')
12633 end if
12634
12635
12636 allocate( mask_array( &
12637 & answer_shape(1), &
12638
12639 & answer_shape(2), &
12640
12641 & answer_shape(3), &
12642
12643 & answer_shape(4) ) &
12644 & )
12645
12646 allocate( judge( &
12647 & answer_shape(1), &
12648
12649 & answer_shape(2), &
12650
12651 & answer_shape(3), &
12652
12653 & answer_shape(4) ) &
12654 & )
12655
12656 allocate( judge_rev( &
12657 & answer_shape(1), &
12658
12659 & answer_shape(2), &
12660
12661 & answer_shape(3), &
12662
12663 & answer_shape(4) ) &
12664 & )
12665
12666 allocate( answer_negative( &
12667 & answer_shape(1), &
12668
12669 & answer_shape(2), &
12670
12671 & answer_shape(3), &
12672
12673 & answer_shape(4) ) &
12674 & )
12675
12676 allocate( check_negative( &
12677 & answer_shape(1), &
12678
12679 & answer_shape(2), &
12680
12681 & answer_shape(3), &
12682
12683 & answer_shape(4) ) &
12684 & )
12685
12686 allocate( both_negative( &
12687 & answer_shape(1), &
12688
12689 & answer_shape(2), &
12690
12691 & answer_shape(3), &
12692
12693 & answer_shape(4) ) &
12694 & )
12695
12696 answer_negative = answer < 0.0_dp
12697 check_negative = check < 0.0_dp
12698 both_negative = answer_negative .and. check_negative
12699 if (.not. negative_support_on) both_negative = .false.
12700
12701 judge = answer < check
12702 where (both_negative) judge = .not. judge
12703
12704 judge_rev = .not. judge
12705 err_flag = any(judge_rev)
12706 mask_array = 1
12707 pos = maxloc(mask_array, judge_rev)
12708
12709 if (err_flag) then
12710
12711 wrong = check( &
12712 & pos(1), &
12713
12714 & pos(2), &
12715
12716 & pos(3), &
12717
12718 & pos(4) )
12719
12720 right = answer( &
12721 & pos(1), &
12722
12723 & pos(2), &
12724
12725 & pos(3), &
12726
12727 & pos(4) )
12728
12729 write(unit=pos_array(1), fmt="(i20)") pos(1)
12730
12731 write(unit=pos_array(2), fmt="(i20)") pos(2)
12732
12733 write(unit=pos_array(3), fmt="(i20)") pos(3)
12734
12735 write(unit=pos_array(4), fmt="(i20)") pos(4)
12736
12737
12738 pos_str = '(' // &
12739 & trim(adjustl(pos_array(1))) // ',' // &
12740
12741 & trim(adjustl(pos_array(2))) // ',' // &
12742
12743 & trim(adjustl(pos_array(3))) // ',' // &
12744
12745 & trim(adjustl(pos_array(4))) // ')'
12746
12747 if ( both_negative( &
12748 & pos(1), &
12749
12750 & pos(2), &
12751
12752 & pos(3), &
12753
12754 & pos(4) ) ) then
12755
12756 abs_mes = 'ABSOLUTE value of'
12757 else
12758 abs_mes = ''
12759
12760 end if
12761
12762 end if
12763 deallocate(mask_array, judge, judge_rev)
12764 deallocate(answer_negative, check_negative, both_negative)
12765
12766
12767
12768
12769 if (err_flag) then
12770 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12771 write(*,*) ''
12772 write(*,*) ' ' // trim(abs_mes) // &
12773 & ' check' // trim(pos_str) // ' = ', wrong
12774 write(*,*) ' is NOT GREATER THAN'
12775 write(*,*) ' ' // trim(abs_mes) // &
12776 & ' answer' // trim(pos_str) // ' = ', right
12777
12778 call abortprogram('')
12779 else
12780 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12781 end if
12782
12783

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthandouble5()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble5 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12787 of file dc_test.f90.

12789 use sysdep, only: abortprogram
12790 use dc_types, only: string, token
12791 implicit none
12792 character(*), intent(in):: message
12793 real(DP), intent(in):: answer(:,:,:,:,:)
12794 real(DP), intent(in):: check(:,:,:,:,:)
12795 logical, intent(in), optional:: negative_support
12796 logical:: err_flag
12797 logical:: negative_support_on
12798 character(STRING):: pos_str
12799 character(TOKEN):: abs_mes
12800 real(DP):: wrong, right
12801
12802 integer:: answer_shape(5), check_shape(5), pos(5)
12803 logical:: consist_shape(5)
12804 character(TOKEN):: pos_array(5)
12805 integer, allocatable:: mask_array(:,:,:,:,:)
12806 logical, allocatable:: judge(:,:,:,:,:)
12807 logical, allocatable:: judge_rev(:,:,:,:,:)
12808 logical, allocatable:: answer_negative(:,:,:,:,:)
12809 logical, allocatable:: check_negative(:,:,:,:,:)
12810 logical, allocatable:: both_negative(:,:,:,:,:)
12811
12812
12813 continue
12814 if (present(negative_support)) then
12815 negative_support_on = negative_support
12816 else
12817 negative_support_on = .true.
12818 end if
12819
12820 err_flag = .false.
12821
12822
12823 answer_shape = shape(answer)
12824 check_shape = shape(check)
12825
12826 consist_shape = answer_shape == check_shape
12827
12828 if (.not. all(consist_shape)) then
12829 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12830 write(*,*) ''
12831 write(*,*) ' shape of check is (', check_shape, ')'
12832 write(*,*) ' is INCORRECT'
12833 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12834
12835 call abortprogram('')
12836 end if
12837
12838
12839 allocate( mask_array( &
12840 & answer_shape(1), &
12841
12842 & answer_shape(2), &
12843
12844 & answer_shape(3), &
12845
12846 & answer_shape(4), &
12847
12848 & answer_shape(5) ) &
12849 & )
12850
12851 allocate( judge( &
12852 & answer_shape(1), &
12853
12854 & answer_shape(2), &
12855
12856 & answer_shape(3), &
12857
12858 & answer_shape(4), &
12859
12860 & answer_shape(5) ) &
12861 & )
12862
12863 allocate( judge_rev( &
12864 & answer_shape(1), &
12865
12866 & answer_shape(2), &
12867
12868 & answer_shape(3), &
12869
12870 & answer_shape(4), &
12871
12872 & answer_shape(5) ) &
12873 & )
12874
12875 allocate( answer_negative( &
12876 & answer_shape(1), &
12877
12878 & answer_shape(2), &
12879
12880 & answer_shape(3), &
12881
12882 & answer_shape(4), &
12883
12884 & answer_shape(5) ) &
12885 & )
12886
12887 allocate( check_negative( &
12888 & answer_shape(1), &
12889
12890 & answer_shape(2), &
12891
12892 & answer_shape(3), &
12893
12894 & answer_shape(4), &
12895
12896 & answer_shape(5) ) &
12897 & )
12898
12899 allocate( both_negative( &
12900 & answer_shape(1), &
12901
12902 & answer_shape(2), &
12903
12904 & answer_shape(3), &
12905
12906 & answer_shape(4), &
12907
12908 & answer_shape(5) ) &
12909 & )
12910
12911 answer_negative = answer < 0.0_dp
12912 check_negative = check < 0.0_dp
12913 both_negative = answer_negative .and. check_negative
12914 if (.not. negative_support_on) both_negative = .false.
12915
12916 judge = answer < check
12917 where (both_negative) judge = .not. judge
12918
12919 judge_rev = .not. judge
12920 err_flag = any(judge_rev)
12921 mask_array = 1
12922 pos = maxloc(mask_array, judge_rev)
12923
12924 if (err_flag) then
12925
12926 wrong = check( &
12927 & pos(1), &
12928
12929 & pos(2), &
12930
12931 & pos(3), &
12932
12933 & pos(4), &
12934
12935 & pos(5) )
12936
12937 right = answer( &
12938 & pos(1), &
12939
12940 & pos(2), &
12941
12942 & pos(3), &
12943
12944 & pos(4), &
12945
12946 & pos(5) )
12947
12948 write(unit=pos_array(1), fmt="(i20)") pos(1)
12949
12950 write(unit=pos_array(2), fmt="(i20)") pos(2)
12951
12952 write(unit=pos_array(3), fmt="(i20)") pos(3)
12953
12954 write(unit=pos_array(4), fmt="(i20)") pos(4)
12955
12956 write(unit=pos_array(5), fmt="(i20)") pos(5)
12957
12958
12959 pos_str = '(' // &
12960 & trim(adjustl(pos_array(1))) // ',' // &
12961
12962 & trim(adjustl(pos_array(2))) // ',' // &
12963
12964 & trim(adjustl(pos_array(3))) // ',' // &
12965
12966 & trim(adjustl(pos_array(4))) // ',' // &
12967
12968 & trim(adjustl(pos_array(5))) // ')'
12969
12970 if ( both_negative( &
12971 & pos(1), &
12972
12973 & pos(2), &
12974
12975 & pos(3), &
12976
12977 & pos(4), &
12978
12979 & pos(5) ) ) then
12980
12981 abs_mes = 'ABSOLUTE value of'
12982 else
12983 abs_mes = ''
12984
12985 end if
12986
12987 end if
12988 deallocate(mask_array, judge, judge_rev)
12989 deallocate(answer_negative, check_negative, both_negative)
12990
12991
12992
12993
12994 if (err_flag) then
12995 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12996 write(*,*) ''
12997 write(*,*) ' ' // trim(abs_mes) // &
12998 & ' check' // trim(pos_str) // ' = ', wrong
12999 write(*,*) ' is NOT GREATER THAN'
13000 write(*,*) ' ' // trim(abs_mes) // &
13001 & ' answer' // trim(pos_str) // ' = ', right
13002
13003 call abortprogram('')
13004 else
13005 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13006 end if
13007
13008

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthandouble6()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble6 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13012 of file dc_test.f90.

13014 use sysdep, only: abortprogram
13015 use dc_types, only: string, token
13016 implicit none
13017 character(*), intent(in):: message
13018 real(DP), intent(in):: answer(:,:,:,:,:,:)
13019 real(DP), intent(in):: check(:,:,:,:,:,:)
13020 logical, intent(in), optional:: negative_support
13021 logical:: err_flag
13022 logical:: negative_support_on
13023 character(STRING):: pos_str
13024 character(TOKEN):: abs_mes
13025 real(DP):: wrong, right
13026
13027 integer:: answer_shape(6), check_shape(6), pos(6)
13028 logical:: consist_shape(6)
13029 character(TOKEN):: pos_array(6)
13030 integer, allocatable:: mask_array(:,:,:,:,:,:)
13031 logical, allocatable:: judge(:,:,:,:,:,:)
13032 logical, allocatable:: judge_rev(:,:,:,:,:,:)
13033 logical, allocatable:: answer_negative(:,:,:,:,:,:)
13034 logical, allocatable:: check_negative(:,:,:,:,:,:)
13035 logical, allocatable:: both_negative(:,:,:,:,:,:)
13036
13037
13038 continue
13039 if (present(negative_support)) then
13040 negative_support_on = negative_support
13041 else
13042 negative_support_on = .true.
13043 end if
13044
13045 err_flag = .false.
13046
13047
13048 answer_shape = shape(answer)
13049 check_shape = shape(check)
13050
13051 consist_shape = answer_shape == check_shape
13052
13053 if (.not. all(consist_shape)) then
13054 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13055 write(*,*) ''
13056 write(*,*) ' shape of check is (', check_shape, ')'
13057 write(*,*) ' is INCORRECT'
13058 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13059
13060 call abortprogram('')
13061 end if
13062
13063
13064 allocate( mask_array( &
13065 & answer_shape(1), &
13066
13067 & answer_shape(2), &
13068
13069 & answer_shape(3), &
13070
13071 & answer_shape(4), &
13072
13073 & answer_shape(5), &
13074
13075 & answer_shape(6) ) &
13076 & )
13077
13078 allocate( judge( &
13079 & answer_shape(1), &
13080
13081 & answer_shape(2), &
13082
13083 & answer_shape(3), &
13084
13085 & answer_shape(4), &
13086
13087 & answer_shape(5), &
13088
13089 & answer_shape(6) ) &
13090 & )
13091
13092 allocate( judge_rev( &
13093 & answer_shape(1), &
13094
13095 & answer_shape(2), &
13096
13097 & answer_shape(3), &
13098
13099 & answer_shape(4), &
13100
13101 & answer_shape(5), &
13102
13103 & answer_shape(6) ) &
13104 & )
13105
13106 allocate( answer_negative( &
13107 & answer_shape(1), &
13108
13109 & answer_shape(2), &
13110
13111 & answer_shape(3), &
13112
13113 & answer_shape(4), &
13114
13115 & answer_shape(5), &
13116
13117 & answer_shape(6) ) &
13118 & )
13119
13120 allocate( check_negative( &
13121 & answer_shape(1), &
13122
13123 & answer_shape(2), &
13124
13125 & answer_shape(3), &
13126
13127 & answer_shape(4), &
13128
13129 & answer_shape(5), &
13130
13131 & answer_shape(6) ) &
13132 & )
13133
13134 allocate( both_negative( &
13135 & answer_shape(1), &
13136
13137 & answer_shape(2), &
13138
13139 & answer_shape(3), &
13140
13141 & answer_shape(4), &
13142
13143 & answer_shape(5), &
13144
13145 & answer_shape(6) ) &
13146 & )
13147
13148 answer_negative = answer < 0.0_dp
13149 check_negative = check < 0.0_dp
13150 both_negative = answer_negative .and. check_negative
13151 if (.not. negative_support_on) both_negative = .false.
13152
13153 judge = answer < check
13154 where (both_negative) judge = .not. judge
13155
13156 judge_rev = .not. judge
13157 err_flag = any(judge_rev)
13158 mask_array = 1
13159 pos = maxloc(mask_array, judge_rev)
13160
13161 if (err_flag) then
13162
13163 wrong = check( &
13164 & pos(1), &
13165
13166 & pos(2), &
13167
13168 & pos(3), &
13169
13170 & pos(4), &
13171
13172 & pos(5), &
13173
13174 & pos(6) )
13175
13176 right = answer( &
13177 & pos(1), &
13178
13179 & pos(2), &
13180
13181 & pos(3), &
13182
13183 & pos(4), &
13184
13185 & pos(5), &
13186
13187 & pos(6) )
13188
13189 write(unit=pos_array(1), fmt="(i20)") pos(1)
13190
13191 write(unit=pos_array(2), fmt="(i20)") pos(2)
13192
13193 write(unit=pos_array(3), fmt="(i20)") pos(3)
13194
13195 write(unit=pos_array(4), fmt="(i20)") pos(4)
13196
13197 write(unit=pos_array(5), fmt="(i20)") pos(5)
13198
13199 write(unit=pos_array(6), fmt="(i20)") pos(6)
13200
13201
13202 pos_str = '(' // &
13203 & trim(adjustl(pos_array(1))) // ',' // &
13204
13205 & trim(adjustl(pos_array(2))) // ',' // &
13206
13207 & trim(adjustl(pos_array(3))) // ',' // &
13208
13209 & trim(adjustl(pos_array(4))) // ',' // &
13210
13211 & trim(adjustl(pos_array(5))) // ',' // &
13212
13213 & trim(adjustl(pos_array(6))) // ')'
13214
13215 if ( both_negative( &
13216 & pos(1), &
13217
13218 & pos(2), &
13219
13220 & pos(3), &
13221
13222 & pos(4), &
13223
13224 & pos(5), &
13225
13226 & pos(6) ) ) then
13227
13228 abs_mes = 'ABSOLUTE value of'
13229 else
13230 abs_mes = ''
13231
13232 end if
13233
13234 end if
13235 deallocate(mask_array, judge, judge_rev)
13236 deallocate(answer_negative, check_negative, both_negative)
13237
13238
13239
13240
13241 if (err_flag) then
13242 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13243 write(*,*) ''
13244 write(*,*) ' ' // trim(abs_mes) // &
13245 & ' check' // trim(pos_str) // ' = ', wrong
13246 write(*,*) ' is NOT GREATER THAN'
13247 write(*,*) ' ' // trim(abs_mes) // &
13248 & ' answer' // trim(pos_str) // ' = ', right
13249
13250 call abortprogram('')
13251 else
13252 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13253 end if
13254
13255

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthandouble7()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthandouble7 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13259 of file dc_test.f90.

13261 use sysdep, only: abortprogram
13262 use dc_types, only: string, token
13263 implicit none
13264 character(*), intent(in):: message
13265 real(DP), intent(in):: answer(:,:,:,:,:,:,:)
13266 real(DP), intent(in):: check(:,:,:,:,:,:,:)
13267 logical, intent(in), optional:: negative_support
13268 logical:: err_flag
13269 logical:: negative_support_on
13270 character(STRING):: pos_str
13271 character(TOKEN):: abs_mes
13272 real(DP):: wrong, right
13273
13274 integer:: answer_shape(7), check_shape(7), pos(7)
13275 logical:: consist_shape(7)
13276 character(TOKEN):: pos_array(7)
13277 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
13278 logical, allocatable:: judge(:,:,:,:,:,:,:)
13279 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
13280 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
13281 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
13282 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
13283
13284
13285 continue
13286 if (present(negative_support)) then
13287 negative_support_on = negative_support
13288 else
13289 negative_support_on = .true.
13290 end if
13291
13292 err_flag = .false.
13293
13294
13295 answer_shape = shape(answer)
13296 check_shape = shape(check)
13297
13298 consist_shape = answer_shape == check_shape
13299
13300 if (.not. all(consist_shape)) then
13301 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13302 write(*,*) ''
13303 write(*,*) ' shape of check is (', check_shape, ')'
13304 write(*,*) ' is INCORRECT'
13305 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13306
13307 call abortprogram('')
13308 end if
13309
13310
13311 allocate( mask_array( &
13312 & answer_shape(1), &
13313
13314 & answer_shape(2), &
13315
13316 & answer_shape(3), &
13317
13318 & answer_shape(4), &
13319
13320 & answer_shape(5), &
13321
13322 & answer_shape(6), &
13323
13324 & answer_shape(7) ) &
13325 & )
13326
13327 allocate( judge( &
13328 & answer_shape(1), &
13329
13330 & answer_shape(2), &
13331
13332 & answer_shape(3), &
13333
13334 & answer_shape(4), &
13335
13336 & answer_shape(5), &
13337
13338 & answer_shape(6), &
13339
13340 & answer_shape(7) ) &
13341 & )
13342
13343 allocate( judge_rev( &
13344 & answer_shape(1), &
13345
13346 & answer_shape(2), &
13347
13348 & answer_shape(3), &
13349
13350 & answer_shape(4), &
13351
13352 & answer_shape(5), &
13353
13354 & answer_shape(6), &
13355
13356 & answer_shape(7) ) &
13357 & )
13358
13359 allocate( answer_negative( &
13360 & answer_shape(1), &
13361
13362 & answer_shape(2), &
13363
13364 & answer_shape(3), &
13365
13366 & answer_shape(4), &
13367
13368 & answer_shape(5), &
13369
13370 & answer_shape(6), &
13371
13372 & answer_shape(7) ) &
13373 & )
13374
13375 allocate( check_negative( &
13376 & answer_shape(1), &
13377
13378 & answer_shape(2), &
13379
13380 & answer_shape(3), &
13381
13382 & answer_shape(4), &
13383
13384 & answer_shape(5), &
13385
13386 & answer_shape(6), &
13387
13388 & answer_shape(7) ) &
13389 & )
13390
13391 allocate( both_negative( &
13392 & answer_shape(1), &
13393
13394 & answer_shape(2), &
13395
13396 & answer_shape(3), &
13397
13398 & answer_shape(4), &
13399
13400 & answer_shape(5), &
13401
13402 & answer_shape(6), &
13403
13404 & answer_shape(7) ) &
13405 & )
13406
13407 answer_negative = answer < 0.0_dp
13408 check_negative = check < 0.0_dp
13409 both_negative = answer_negative .and. check_negative
13410 if (.not. negative_support_on) both_negative = .false.
13411
13412 judge = answer < check
13413 where (both_negative) judge = .not. judge
13414
13415 judge_rev = .not. judge
13416 err_flag = any(judge_rev)
13417 mask_array = 1
13418 pos = maxloc(mask_array, judge_rev)
13419
13420 if (err_flag) then
13421
13422 wrong = check( &
13423 & pos(1), &
13424
13425 & pos(2), &
13426
13427 & pos(3), &
13428
13429 & pos(4), &
13430
13431 & pos(5), &
13432
13433 & pos(6), &
13434
13435 & pos(7) )
13436
13437 right = answer( &
13438 & pos(1), &
13439
13440 & pos(2), &
13441
13442 & pos(3), &
13443
13444 & pos(4), &
13445
13446 & pos(5), &
13447
13448 & pos(6), &
13449
13450 & pos(7) )
13451
13452 write(unit=pos_array(1), fmt="(i20)") pos(1)
13453
13454 write(unit=pos_array(2), fmt="(i20)") pos(2)
13455
13456 write(unit=pos_array(3), fmt="(i20)") pos(3)
13457
13458 write(unit=pos_array(4), fmt="(i20)") pos(4)
13459
13460 write(unit=pos_array(5), fmt="(i20)") pos(5)
13461
13462 write(unit=pos_array(6), fmt="(i20)") pos(6)
13463
13464 write(unit=pos_array(7), fmt="(i20)") pos(7)
13465
13466
13467 pos_str = '(' // &
13468 & trim(adjustl(pos_array(1))) // ',' // &
13469
13470 & trim(adjustl(pos_array(2))) // ',' // &
13471
13472 & trim(adjustl(pos_array(3))) // ',' // &
13473
13474 & trim(adjustl(pos_array(4))) // ',' // &
13475
13476 & trim(adjustl(pos_array(5))) // ',' // &
13477
13478 & trim(adjustl(pos_array(6))) // ',' // &
13479
13480 & trim(adjustl(pos_array(7))) // ')'
13481
13482 if ( both_negative( &
13483 & pos(1), &
13484
13485 & pos(2), &
13486
13487 & pos(3), &
13488
13489 & pos(4), &
13490
13491 & pos(5), &
13492
13493 & pos(6), &
13494
13495 & pos(7) ) ) then
13496
13497 abs_mes = 'ABSOLUTE value of'
13498 else
13499 abs_mes = ''
13500
13501 end if
13502
13503 end if
13504 deallocate(mask_array, judge, judge_rev)
13505 deallocate(answer_negative, check_negative, both_negative)
13506
13507
13508
13509
13510 if (err_flag) then
13511 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13512 write(*,*) ''
13513 write(*,*) ' ' // trim(abs_mes) // &
13514 & ' check' // trim(pos_str) // ' = ', wrong
13515 write(*,*) ' is NOT GREATER THAN'
13516 write(*,*) ' ' // trim(abs_mes) // &
13517 & ' answer' // trim(pos_str) // ' = ', right
13518
13519 call abortprogram('')
13520 else
13521 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13522 end if
13523
13524

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint0()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint0 ( character(*), intent(in)  message,
integer, intent(in)  answer,
integer, intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9046 of file dc_test.f90.

9048 use sysdep, only: abortprogram
9049 use dc_types, only: string, token
9050 implicit none
9051 character(*), intent(in):: message
9052 integer, intent(in):: answer
9053 integer, intent(in):: check
9054 logical, intent(in), optional:: negative_support
9055 logical:: err_flag
9056 logical:: negative_support_on
9057 character(STRING):: pos_str
9058 character(TOKEN):: abs_mes
9059 integer:: wrong, right
9060
9061
9062
9063 continue
9064 if (present(negative_support)) then
9065 negative_support_on = negative_support
9066 else
9067 negative_support_on = .true.
9068 end if
9069
9070 err_flag = .false.
9071
9072
9073 err_flag = .not. answer < check
9074 abs_mes = ''
9075
9076 if ( answer < 0 &
9077 & .and. check < 0 &
9078 & .and. negative_support_on ) then
9079
9080 err_flag = .not. err_flag
9081 abs_mes = 'ABSOLUTE value of'
9082 end if
9083
9084 wrong = check
9085 right = answer
9086 pos_str = ''
9087
9088
9089
9090
9091 if (err_flag) then
9092 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9093 write(*,*) ''
9094 write(*,*) ' ' // trim(abs_mes) // &
9095 & ' check' // trim(pos_str) // ' = ', wrong
9096 write(*,*) ' is NOT GREATER THAN'
9097 write(*,*) ' ' // trim(abs_mes) // &
9098 & ' answer' // trim(pos_str) // ' = ', right
9099
9100 call abortprogram('')
9101 else
9102 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9103 end if
9104
9105

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint1()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint1 ( character(*), intent(in)  message,
integer, dimension(:), intent(in)  answer,
integer, dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9109 of file dc_test.f90.

9111 use sysdep, only: abortprogram
9112 use dc_types, only: string, token
9113 implicit none
9114 character(*), intent(in):: message
9115 integer, intent(in):: answer(:)
9116 integer, intent(in):: check(:)
9117 logical, intent(in), optional:: negative_support
9118 logical:: err_flag
9119 logical:: negative_support_on
9120 character(STRING):: pos_str
9121 character(TOKEN):: abs_mes
9122 integer:: wrong, right
9123
9124 integer:: answer_shape(1), check_shape(1), pos(1)
9125 logical:: consist_shape(1)
9126 character(TOKEN):: pos_array(1)
9127 integer, allocatable:: mask_array(:)
9128 logical, allocatable:: judge(:)
9129 logical, allocatable:: judge_rev(:)
9130 logical, allocatable:: answer_negative(:)
9131 logical, allocatable:: check_negative(:)
9132 logical, allocatable:: both_negative(:)
9133
9134
9135 continue
9136 if (present(negative_support)) then
9137 negative_support_on = negative_support
9138 else
9139 negative_support_on = .true.
9140 end if
9141
9142 err_flag = .false.
9143
9144
9145 answer_shape = shape(answer)
9146 check_shape = shape(check)
9147
9148 consist_shape = answer_shape == check_shape
9149
9150 if (.not. all(consist_shape)) then
9151 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9152 write(*,*) ''
9153 write(*,*) ' shape of check is (', check_shape, ')'
9154 write(*,*) ' is INCORRECT'
9155 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9156
9157 call abortprogram('')
9158 end if
9159
9160
9161 allocate( mask_array( &
9162
9163 & answer_shape(1) ) &
9164 & )
9165
9166 allocate( judge( &
9167
9168 & answer_shape(1) ) &
9169 & )
9170
9171 allocate( judge_rev( &
9172
9173 & answer_shape(1) ) &
9174 & )
9175
9176 allocate( answer_negative( &
9177
9178 & answer_shape(1) ) &
9179 & )
9180
9181 allocate( check_negative( &
9182
9183 & answer_shape(1) ) &
9184 & )
9185
9186 allocate( both_negative( &
9187
9188 & answer_shape(1) ) &
9189 & )
9190
9191 answer_negative = answer < 0
9192 check_negative = check < 0
9193 both_negative = answer_negative .and. check_negative
9194 if (.not. negative_support_on) both_negative = .false.
9195
9196 judge = answer < check
9197 where (both_negative) judge = .not. judge
9198
9199 judge_rev = .not. judge
9200 err_flag = any(judge_rev)
9201 mask_array = 1
9202 pos = maxloc(mask_array, judge_rev)
9203
9204 if (err_flag) then
9205
9206 wrong = check( &
9207
9208 & pos(1) )
9209
9210 right = answer( &
9211
9212 & pos(1) )
9213
9214 write(unit=pos_array(1), fmt="(i20)") pos(1)
9215
9216
9217 pos_str = '(' // &
9218
9219 & trim(adjustl(pos_array(1))) // ')'
9220
9221 if ( both_negative( &
9222
9223 & pos(1) ) ) then
9224
9225 abs_mes = 'ABSOLUTE value of'
9226 else
9227 abs_mes = ''
9228
9229 end if
9230
9231 end if
9232 deallocate(mask_array, judge, judge_rev)
9233 deallocate(answer_negative, check_negative, both_negative)
9234
9235
9236
9237
9238 if (err_flag) then
9239 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9240 write(*,*) ''
9241 write(*,*) ' ' // trim(abs_mes) // &
9242 & ' check' // trim(pos_str) // ' = ', wrong
9243 write(*,*) ' is NOT GREATER THAN'
9244 write(*,*) ' ' // trim(abs_mes) // &
9245 & ' answer' // trim(pos_str) // ' = ', right
9246
9247 call abortprogram('')
9248 else
9249 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9250 end if
9251
9252

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint2()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint2 ( character(*), intent(in)  message,
integer, dimension(:,:), intent(in)  answer,
integer, dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9256 of file dc_test.f90.

9258 use sysdep, only: abortprogram
9259 use dc_types, only: string, token
9260 implicit none
9261 character(*), intent(in):: message
9262 integer, intent(in):: answer(:,:)
9263 integer, intent(in):: check(:,:)
9264 logical, intent(in), optional:: negative_support
9265 logical:: err_flag
9266 logical:: negative_support_on
9267 character(STRING):: pos_str
9268 character(TOKEN):: abs_mes
9269 integer:: wrong, right
9270
9271 integer:: answer_shape(2), check_shape(2), pos(2)
9272 logical:: consist_shape(2)
9273 character(TOKEN):: pos_array(2)
9274 integer, allocatable:: mask_array(:,:)
9275 logical, allocatable:: judge(:,:)
9276 logical, allocatable:: judge_rev(:,:)
9277 logical, allocatable:: answer_negative(:,:)
9278 logical, allocatable:: check_negative(:,:)
9279 logical, allocatable:: both_negative(:,:)
9280
9281
9282 continue
9283 if (present(negative_support)) then
9284 negative_support_on = negative_support
9285 else
9286 negative_support_on = .true.
9287 end if
9288
9289 err_flag = .false.
9290
9291
9292 answer_shape = shape(answer)
9293 check_shape = shape(check)
9294
9295 consist_shape = answer_shape == check_shape
9296
9297 if (.not. all(consist_shape)) then
9298 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9299 write(*,*) ''
9300 write(*,*) ' shape of check is (', check_shape, ')'
9301 write(*,*) ' is INCORRECT'
9302 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9303
9304 call abortprogram('')
9305 end if
9306
9307
9308 allocate( mask_array( &
9309 & answer_shape(1), &
9310
9311 & answer_shape(2) ) &
9312 & )
9313
9314 allocate( judge( &
9315 & answer_shape(1), &
9316
9317 & answer_shape(2) ) &
9318 & )
9319
9320 allocate( judge_rev( &
9321 & answer_shape(1), &
9322
9323 & answer_shape(2) ) &
9324 & )
9325
9326 allocate( answer_negative( &
9327 & answer_shape(1), &
9328
9329 & answer_shape(2) ) &
9330 & )
9331
9332 allocate( check_negative( &
9333 & answer_shape(1), &
9334
9335 & answer_shape(2) ) &
9336 & )
9337
9338 allocate( both_negative( &
9339 & answer_shape(1), &
9340
9341 & answer_shape(2) ) &
9342 & )
9343
9344 answer_negative = answer < 0
9345 check_negative = check < 0
9346 both_negative = answer_negative .and. check_negative
9347 if (.not. negative_support_on) both_negative = .false.
9348
9349 judge = answer < check
9350 where (both_negative) judge = .not. judge
9351
9352 judge_rev = .not. judge
9353 err_flag = any(judge_rev)
9354 mask_array = 1
9355 pos = maxloc(mask_array, judge_rev)
9356
9357 if (err_flag) then
9358
9359 wrong = check( &
9360 & pos(1), &
9361
9362 & pos(2) )
9363
9364 right = answer( &
9365 & pos(1), &
9366
9367 & pos(2) )
9368
9369 write(unit=pos_array(1), fmt="(i20)") pos(1)
9370
9371 write(unit=pos_array(2), fmt="(i20)") pos(2)
9372
9373
9374 pos_str = '(' // &
9375 & trim(adjustl(pos_array(1))) // ',' // &
9376
9377 & trim(adjustl(pos_array(2))) // ')'
9378
9379 if ( both_negative( &
9380 & pos(1), &
9381
9382 & pos(2) ) ) then
9383
9384 abs_mes = 'ABSOLUTE value of'
9385 else
9386 abs_mes = ''
9387
9388 end if
9389
9390 end if
9391 deallocate(mask_array, judge, judge_rev)
9392 deallocate(answer_negative, check_negative, both_negative)
9393
9394
9395
9396
9397 if (err_flag) then
9398 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9399 write(*,*) ''
9400 write(*,*) ' ' // trim(abs_mes) // &
9401 & ' check' // trim(pos_str) // ' = ', wrong
9402 write(*,*) ' is NOT GREATER THAN'
9403 write(*,*) ' ' // trim(abs_mes) // &
9404 & ' answer' // trim(pos_str) // ' = ', right
9405
9406 call abortprogram('')
9407 else
9408 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9409 end if
9410
9411

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint3()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint3 ( character(*), intent(in)  message,
integer, dimension(:,:,:), intent(in)  answer,
integer, dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9415 of file dc_test.f90.

9417 use sysdep, only: abortprogram
9418 use dc_types, only: string, token
9419 implicit none
9420 character(*), intent(in):: message
9421 integer, intent(in):: answer(:,:,:)
9422 integer, intent(in):: check(:,:,:)
9423 logical, intent(in), optional:: negative_support
9424 logical:: err_flag
9425 logical:: negative_support_on
9426 character(STRING):: pos_str
9427 character(TOKEN):: abs_mes
9428 integer:: wrong, right
9429
9430 integer:: answer_shape(3), check_shape(3), pos(3)
9431 logical:: consist_shape(3)
9432 character(TOKEN):: pos_array(3)
9433 integer, allocatable:: mask_array(:,:,:)
9434 logical, allocatable:: judge(:,:,:)
9435 logical, allocatable:: judge_rev(:,:,:)
9436 logical, allocatable:: answer_negative(:,:,:)
9437 logical, allocatable:: check_negative(:,:,:)
9438 logical, allocatable:: both_negative(:,:,:)
9439
9440
9441 continue
9442 if (present(negative_support)) then
9443 negative_support_on = negative_support
9444 else
9445 negative_support_on = .true.
9446 end if
9447
9448 err_flag = .false.
9449
9450
9451 answer_shape = shape(answer)
9452 check_shape = shape(check)
9453
9454 consist_shape = answer_shape == check_shape
9455
9456 if (.not. all(consist_shape)) then
9457 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9458 write(*,*) ''
9459 write(*,*) ' shape of check is (', check_shape, ')'
9460 write(*,*) ' is INCORRECT'
9461 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9462
9463 call abortprogram('')
9464 end if
9465
9466
9467 allocate( mask_array( &
9468 & answer_shape(1), &
9469
9470 & answer_shape(2), &
9471
9472 & answer_shape(3) ) &
9473 & )
9474
9475 allocate( judge( &
9476 & answer_shape(1), &
9477
9478 & answer_shape(2), &
9479
9480 & answer_shape(3) ) &
9481 & )
9482
9483 allocate( judge_rev( &
9484 & answer_shape(1), &
9485
9486 & answer_shape(2), &
9487
9488 & answer_shape(3) ) &
9489 & )
9490
9491 allocate( answer_negative( &
9492 & answer_shape(1), &
9493
9494 & answer_shape(2), &
9495
9496 & answer_shape(3) ) &
9497 & )
9498
9499 allocate( check_negative( &
9500 & answer_shape(1), &
9501
9502 & answer_shape(2), &
9503
9504 & answer_shape(3) ) &
9505 & )
9506
9507 allocate( both_negative( &
9508 & answer_shape(1), &
9509
9510 & answer_shape(2), &
9511
9512 & answer_shape(3) ) &
9513 & )
9514
9515 answer_negative = answer < 0
9516 check_negative = check < 0
9517 both_negative = answer_negative .and. check_negative
9518 if (.not. negative_support_on) both_negative = .false.
9519
9520 judge = answer < check
9521 where (both_negative) judge = .not. judge
9522
9523 judge_rev = .not. judge
9524 err_flag = any(judge_rev)
9525 mask_array = 1
9526 pos = maxloc(mask_array, judge_rev)
9527
9528 if (err_flag) then
9529
9530 wrong = check( &
9531 & pos(1), &
9532
9533 & pos(2), &
9534
9535 & pos(3) )
9536
9537 right = answer( &
9538 & pos(1), &
9539
9540 & pos(2), &
9541
9542 & pos(3) )
9543
9544 write(unit=pos_array(1), fmt="(i20)") pos(1)
9545
9546 write(unit=pos_array(2), fmt="(i20)") pos(2)
9547
9548 write(unit=pos_array(3), fmt="(i20)") pos(3)
9549
9550
9551 pos_str = '(' // &
9552 & trim(adjustl(pos_array(1))) // ',' // &
9553
9554 & trim(adjustl(pos_array(2))) // ',' // &
9555
9556 & trim(adjustl(pos_array(3))) // ')'
9557
9558 if ( both_negative( &
9559 & pos(1), &
9560
9561 & pos(2), &
9562
9563 & pos(3) ) ) then
9564
9565 abs_mes = 'ABSOLUTE value of'
9566 else
9567 abs_mes = ''
9568
9569 end if
9570
9571 end if
9572 deallocate(mask_array, judge, judge_rev)
9573 deallocate(answer_negative, check_negative, both_negative)
9574
9575
9576
9577
9578 if (err_flag) then
9579 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9580 write(*,*) ''
9581 write(*,*) ' ' // trim(abs_mes) // &
9582 & ' check' // trim(pos_str) // ' = ', wrong
9583 write(*,*) ' is NOT GREATER THAN'
9584 write(*,*) ' ' // trim(abs_mes) // &
9585 & ' answer' // trim(pos_str) // ' = ', right
9586
9587 call abortprogram('')
9588 else
9589 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9590 end if
9591
9592

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint4()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint4 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9596 of file dc_test.f90.

9598 use sysdep, only: abortprogram
9599 use dc_types, only: string, token
9600 implicit none
9601 character(*), intent(in):: message
9602 integer, intent(in):: answer(:,:,:,:)
9603 integer, intent(in):: check(:,:,:,:)
9604 logical, intent(in), optional:: negative_support
9605 logical:: err_flag
9606 logical:: negative_support_on
9607 character(STRING):: pos_str
9608 character(TOKEN):: abs_mes
9609 integer:: wrong, right
9610
9611 integer:: answer_shape(4), check_shape(4), pos(4)
9612 logical:: consist_shape(4)
9613 character(TOKEN):: pos_array(4)
9614 integer, allocatable:: mask_array(:,:,:,:)
9615 logical, allocatable:: judge(:,:,:,:)
9616 logical, allocatable:: judge_rev(:,:,:,:)
9617 logical, allocatable:: answer_negative(:,:,:,:)
9618 logical, allocatable:: check_negative(:,:,:,:)
9619 logical, allocatable:: both_negative(:,:,:,:)
9620
9621
9622 continue
9623 if (present(negative_support)) then
9624 negative_support_on = negative_support
9625 else
9626 negative_support_on = .true.
9627 end if
9628
9629 err_flag = .false.
9630
9631
9632 answer_shape = shape(answer)
9633 check_shape = shape(check)
9634
9635 consist_shape = answer_shape == check_shape
9636
9637 if (.not. all(consist_shape)) then
9638 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9639 write(*,*) ''
9640 write(*,*) ' shape of check is (', check_shape, ')'
9641 write(*,*) ' is INCORRECT'
9642 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9643
9644 call abortprogram('')
9645 end if
9646
9647
9648 allocate( mask_array( &
9649 & answer_shape(1), &
9650
9651 & answer_shape(2), &
9652
9653 & answer_shape(3), &
9654
9655 & answer_shape(4) ) &
9656 & )
9657
9658 allocate( judge( &
9659 & answer_shape(1), &
9660
9661 & answer_shape(2), &
9662
9663 & answer_shape(3), &
9664
9665 & answer_shape(4) ) &
9666 & )
9667
9668 allocate( judge_rev( &
9669 & answer_shape(1), &
9670
9671 & answer_shape(2), &
9672
9673 & answer_shape(3), &
9674
9675 & answer_shape(4) ) &
9676 & )
9677
9678 allocate( answer_negative( &
9679 & answer_shape(1), &
9680
9681 & answer_shape(2), &
9682
9683 & answer_shape(3), &
9684
9685 & answer_shape(4) ) &
9686 & )
9687
9688 allocate( check_negative( &
9689 & answer_shape(1), &
9690
9691 & answer_shape(2), &
9692
9693 & answer_shape(3), &
9694
9695 & answer_shape(4) ) &
9696 & )
9697
9698 allocate( both_negative( &
9699 & answer_shape(1), &
9700
9701 & answer_shape(2), &
9702
9703 & answer_shape(3), &
9704
9705 & answer_shape(4) ) &
9706 & )
9707
9708 answer_negative = answer < 0
9709 check_negative = check < 0
9710 both_negative = answer_negative .and. check_negative
9711 if (.not. negative_support_on) both_negative = .false.
9712
9713 judge = answer < check
9714 where (both_negative) judge = .not. judge
9715
9716 judge_rev = .not. judge
9717 err_flag = any(judge_rev)
9718 mask_array = 1
9719 pos = maxloc(mask_array, judge_rev)
9720
9721 if (err_flag) then
9722
9723 wrong = check( &
9724 & pos(1), &
9725
9726 & pos(2), &
9727
9728 & pos(3), &
9729
9730 & pos(4) )
9731
9732 right = answer( &
9733 & pos(1), &
9734
9735 & pos(2), &
9736
9737 & pos(3), &
9738
9739 & pos(4) )
9740
9741 write(unit=pos_array(1), fmt="(i20)") pos(1)
9742
9743 write(unit=pos_array(2), fmt="(i20)") pos(2)
9744
9745 write(unit=pos_array(3), fmt="(i20)") pos(3)
9746
9747 write(unit=pos_array(4), fmt="(i20)") pos(4)
9748
9749
9750 pos_str = '(' // &
9751 & trim(adjustl(pos_array(1))) // ',' // &
9752
9753 & trim(adjustl(pos_array(2))) // ',' // &
9754
9755 & trim(adjustl(pos_array(3))) // ',' // &
9756
9757 & trim(adjustl(pos_array(4))) // ')'
9758
9759 if ( both_negative( &
9760 & pos(1), &
9761
9762 & pos(2), &
9763
9764 & pos(3), &
9765
9766 & pos(4) ) ) then
9767
9768 abs_mes = 'ABSOLUTE value of'
9769 else
9770 abs_mes = ''
9771
9772 end if
9773
9774 end if
9775 deallocate(mask_array, judge, judge_rev)
9776 deallocate(answer_negative, check_negative, both_negative)
9777
9778
9779
9780
9781 if (err_flag) then
9782 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9783 write(*,*) ''
9784 write(*,*) ' ' // trim(abs_mes) // &
9785 & ' check' // trim(pos_str) // ' = ', wrong
9786 write(*,*) ' is NOT GREATER THAN'
9787 write(*,*) ' ' // trim(abs_mes) // &
9788 & ' answer' // trim(pos_str) // ' = ', right
9789
9790 call abortprogram('')
9791 else
9792 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9793 end if
9794
9795

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint5()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint5 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9799 of file dc_test.f90.

9801 use sysdep, only: abortprogram
9802 use dc_types, only: string, token
9803 implicit none
9804 character(*), intent(in):: message
9805 integer, intent(in):: answer(:,:,:,:,:)
9806 integer, intent(in):: check(:,:,:,:,:)
9807 logical, intent(in), optional:: negative_support
9808 logical:: err_flag
9809 logical:: negative_support_on
9810 character(STRING):: pos_str
9811 character(TOKEN):: abs_mes
9812 integer:: wrong, right
9813
9814 integer:: answer_shape(5), check_shape(5), pos(5)
9815 logical:: consist_shape(5)
9816 character(TOKEN):: pos_array(5)
9817 integer, allocatable:: mask_array(:,:,:,:,:)
9818 logical, allocatable:: judge(:,:,:,:,:)
9819 logical, allocatable:: judge_rev(:,:,:,:,:)
9820 logical, allocatable:: answer_negative(:,:,:,:,:)
9821 logical, allocatable:: check_negative(:,:,:,:,:)
9822 logical, allocatable:: both_negative(:,:,:,:,:)
9823
9824
9825 continue
9826 if (present(negative_support)) then
9827 negative_support_on = negative_support
9828 else
9829 negative_support_on = .true.
9830 end if
9831
9832 err_flag = .false.
9833
9834
9835 answer_shape = shape(answer)
9836 check_shape = shape(check)
9837
9838 consist_shape = answer_shape == check_shape
9839
9840 if (.not. all(consist_shape)) then
9841 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9842 write(*,*) ''
9843 write(*,*) ' shape of check is (', check_shape, ')'
9844 write(*,*) ' is INCORRECT'
9845 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9846
9847 call abortprogram('')
9848 end if
9849
9850
9851 allocate( mask_array( &
9852 & answer_shape(1), &
9853
9854 & answer_shape(2), &
9855
9856 & answer_shape(3), &
9857
9858 & answer_shape(4), &
9859
9860 & answer_shape(5) ) &
9861 & )
9862
9863 allocate( judge( &
9864 & answer_shape(1), &
9865
9866 & answer_shape(2), &
9867
9868 & answer_shape(3), &
9869
9870 & answer_shape(4), &
9871
9872 & answer_shape(5) ) &
9873 & )
9874
9875 allocate( judge_rev( &
9876 & answer_shape(1), &
9877
9878 & answer_shape(2), &
9879
9880 & answer_shape(3), &
9881
9882 & answer_shape(4), &
9883
9884 & answer_shape(5) ) &
9885 & )
9886
9887 allocate( answer_negative( &
9888 & answer_shape(1), &
9889
9890 & answer_shape(2), &
9891
9892 & answer_shape(3), &
9893
9894 & answer_shape(4), &
9895
9896 & answer_shape(5) ) &
9897 & )
9898
9899 allocate( check_negative( &
9900 & answer_shape(1), &
9901
9902 & answer_shape(2), &
9903
9904 & answer_shape(3), &
9905
9906 & answer_shape(4), &
9907
9908 & answer_shape(5) ) &
9909 & )
9910
9911 allocate( both_negative( &
9912 & answer_shape(1), &
9913
9914 & answer_shape(2), &
9915
9916 & answer_shape(3), &
9917
9918 & answer_shape(4), &
9919
9920 & answer_shape(5) ) &
9921 & )
9922
9923 answer_negative = answer < 0
9924 check_negative = check < 0
9925 both_negative = answer_negative .and. check_negative
9926 if (.not. negative_support_on) both_negative = .false.
9927
9928 judge = answer < check
9929 where (both_negative) judge = .not. judge
9930
9931 judge_rev = .not. judge
9932 err_flag = any(judge_rev)
9933 mask_array = 1
9934 pos = maxloc(mask_array, judge_rev)
9935
9936 if (err_flag) then
9937
9938 wrong = check( &
9939 & pos(1), &
9940
9941 & pos(2), &
9942
9943 & pos(3), &
9944
9945 & pos(4), &
9946
9947 & pos(5) )
9948
9949 right = answer( &
9950 & pos(1), &
9951
9952 & pos(2), &
9953
9954 & pos(3), &
9955
9956 & pos(4), &
9957
9958 & pos(5) )
9959
9960 write(unit=pos_array(1), fmt="(i20)") pos(1)
9961
9962 write(unit=pos_array(2), fmt="(i20)") pos(2)
9963
9964 write(unit=pos_array(3), fmt="(i20)") pos(3)
9965
9966 write(unit=pos_array(4), fmt="(i20)") pos(4)
9967
9968 write(unit=pos_array(5), fmt="(i20)") pos(5)
9969
9970
9971 pos_str = '(' // &
9972 & trim(adjustl(pos_array(1))) // ',' // &
9973
9974 & trim(adjustl(pos_array(2))) // ',' // &
9975
9976 & trim(adjustl(pos_array(3))) // ',' // &
9977
9978 & trim(adjustl(pos_array(4))) // ',' // &
9979
9980 & trim(adjustl(pos_array(5))) // ')'
9981
9982 if ( both_negative( &
9983 & pos(1), &
9984
9985 & pos(2), &
9986
9987 & pos(3), &
9988
9989 & pos(4), &
9990
9991 & pos(5) ) ) then
9992
9993 abs_mes = 'ABSOLUTE value of'
9994 else
9995 abs_mes = ''
9996
9997 end if
9998
9999 end if
10000 deallocate(mask_array, judge, judge_rev)
10001 deallocate(answer_negative, check_negative, both_negative)
10002
10003
10004
10005
10006 if (err_flag) then
10007 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10008 write(*,*) ''
10009 write(*,*) ' ' // trim(abs_mes) // &
10010 & ' check' // trim(pos_str) // ' = ', wrong
10011 write(*,*) ' is NOT GREATER THAN'
10012 write(*,*) ' ' // trim(abs_mes) // &
10013 & ' answer' // trim(pos_str) // ' = ', right
10014
10015 call abortprogram('')
10016 else
10017 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10018 end if
10019
10020

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint6()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint6 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10024 of file dc_test.f90.

10026 use sysdep, only: abortprogram
10027 use dc_types, only: string, token
10028 implicit none
10029 character(*), intent(in):: message
10030 integer, intent(in):: answer(:,:,:,:,:,:)
10031 integer, intent(in):: check(:,:,:,:,:,:)
10032 logical, intent(in), optional:: negative_support
10033 logical:: err_flag
10034 logical:: negative_support_on
10035 character(STRING):: pos_str
10036 character(TOKEN):: abs_mes
10037 integer:: wrong, right
10038
10039 integer:: answer_shape(6), check_shape(6), pos(6)
10040 logical:: consist_shape(6)
10041 character(TOKEN):: pos_array(6)
10042 integer, allocatable:: mask_array(:,:,:,:,:,:)
10043 logical, allocatable:: judge(:,:,:,:,:,:)
10044 logical, allocatable:: judge_rev(:,:,:,:,:,:)
10045 logical, allocatable:: answer_negative(:,:,:,:,:,:)
10046 logical, allocatable:: check_negative(:,:,:,:,:,:)
10047 logical, allocatable:: both_negative(:,:,:,:,:,:)
10048
10049
10050 continue
10051 if (present(negative_support)) then
10052 negative_support_on = negative_support
10053 else
10054 negative_support_on = .true.
10055 end if
10056
10057 err_flag = .false.
10058
10059
10060 answer_shape = shape(answer)
10061 check_shape = shape(check)
10062
10063 consist_shape = answer_shape == check_shape
10064
10065 if (.not. all(consist_shape)) then
10066 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10067 write(*,*) ''
10068 write(*,*) ' shape of check is (', check_shape, ')'
10069 write(*,*) ' is INCORRECT'
10070 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10071
10072 call abortprogram('')
10073 end if
10074
10075
10076 allocate( mask_array( &
10077 & answer_shape(1), &
10078
10079 & answer_shape(2), &
10080
10081 & answer_shape(3), &
10082
10083 & answer_shape(4), &
10084
10085 & answer_shape(5), &
10086
10087 & answer_shape(6) ) &
10088 & )
10089
10090 allocate( judge( &
10091 & answer_shape(1), &
10092
10093 & answer_shape(2), &
10094
10095 & answer_shape(3), &
10096
10097 & answer_shape(4), &
10098
10099 & answer_shape(5), &
10100
10101 & answer_shape(6) ) &
10102 & )
10103
10104 allocate( judge_rev( &
10105 & answer_shape(1), &
10106
10107 & answer_shape(2), &
10108
10109 & answer_shape(3), &
10110
10111 & answer_shape(4), &
10112
10113 & answer_shape(5), &
10114
10115 & answer_shape(6) ) &
10116 & )
10117
10118 allocate( answer_negative( &
10119 & answer_shape(1), &
10120
10121 & answer_shape(2), &
10122
10123 & answer_shape(3), &
10124
10125 & answer_shape(4), &
10126
10127 & answer_shape(5), &
10128
10129 & answer_shape(6) ) &
10130 & )
10131
10132 allocate( check_negative( &
10133 & answer_shape(1), &
10134
10135 & answer_shape(2), &
10136
10137 & answer_shape(3), &
10138
10139 & answer_shape(4), &
10140
10141 & answer_shape(5), &
10142
10143 & answer_shape(6) ) &
10144 & )
10145
10146 allocate( both_negative( &
10147 & answer_shape(1), &
10148
10149 & answer_shape(2), &
10150
10151 & answer_shape(3), &
10152
10153 & answer_shape(4), &
10154
10155 & answer_shape(5), &
10156
10157 & answer_shape(6) ) &
10158 & )
10159
10160 answer_negative = answer < 0
10161 check_negative = check < 0
10162 both_negative = answer_negative .and. check_negative
10163 if (.not. negative_support_on) both_negative = .false.
10164
10165 judge = answer < check
10166 where (both_negative) judge = .not. judge
10167
10168 judge_rev = .not. judge
10169 err_flag = any(judge_rev)
10170 mask_array = 1
10171 pos = maxloc(mask_array, judge_rev)
10172
10173 if (err_flag) then
10174
10175 wrong = check( &
10176 & pos(1), &
10177
10178 & pos(2), &
10179
10180 & pos(3), &
10181
10182 & pos(4), &
10183
10184 & pos(5), &
10185
10186 & pos(6) )
10187
10188 right = answer( &
10189 & pos(1), &
10190
10191 & pos(2), &
10192
10193 & pos(3), &
10194
10195 & pos(4), &
10196
10197 & pos(5), &
10198
10199 & pos(6) )
10200
10201 write(unit=pos_array(1), fmt="(i20)") pos(1)
10202
10203 write(unit=pos_array(2), fmt="(i20)") pos(2)
10204
10205 write(unit=pos_array(3), fmt="(i20)") pos(3)
10206
10207 write(unit=pos_array(4), fmt="(i20)") pos(4)
10208
10209 write(unit=pos_array(5), fmt="(i20)") pos(5)
10210
10211 write(unit=pos_array(6), fmt="(i20)") pos(6)
10212
10213
10214 pos_str = '(' // &
10215 & trim(adjustl(pos_array(1))) // ',' // &
10216
10217 & trim(adjustl(pos_array(2))) // ',' // &
10218
10219 & trim(adjustl(pos_array(3))) // ',' // &
10220
10221 & trim(adjustl(pos_array(4))) // ',' // &
10222
10223 & trim(adjustl(pos_array(5))) // ',' // &
10224
10225 & trim(adjustl(pos_array(6))) // ')'
10226
10227 if ( both_negative( &
10228 & pos(1), &
10229
10230 & pos(2), &
10231
10232 & pos(3), &
10233
10234 & pos(4), &
10235
10236 & pos(5), &
10237
10238 & pos(6) ) ) then
10239
10240 abs_mes = 'ABSOLUTE value of'
10241 else
10242 abs_mes = ''
10243
10244 end if
10245
10246 end if
10247 deallocate(mask_array, judge, judge_rev)
10248 deallocate(answer_negative, check_negative, both_negative)
10249
10250
10251
10252
10253 if (err_flag) then
10254 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10255 write(*,*) ''
10256 write(*,*) ' ' // trim(abs_mes) // &
10257 & ' check' // trim(pos_str) // ' = ', wrong
10258 write(*,*) ' is NOT GREATER THAN'
10259 write(*,*) ' ' // trim(abs_mes) // &
10260 & ' answer' // trim(pos_str) // ' = ', right
10261
10262 call abortprogram('')
10263 else
10264 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10265 end if
10266
10267

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanint7()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanint7 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10271 of file dc_test.f90.

10273 use sysdep, only: abortprogram
10274 use dc_types, only: string, token
10275 implicit none
10276 character(*), intent(in):: message
10277 integer, intent(in):: answer(:,:,:,:,:,:,:)
10278 integer, intent(in):: check(:,:,:,:,:,:,:)
10279 logical, intent(in), optional:: negative_support
10280 logical:: err_flag
10281 logical:: negative_support_on
10282 character(STRING):: pos_str
10283 character(TOKEN):: abs_mes
10284 integer:: wrong, right
10285
10286 integer:: answer_shape(7), check_shape(7), pos(7)
10287 logical:: consist_shape(7)
10288 character(TOKEN):: pos_array(7)
10289 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
10290 logical, allocatable:: judge(:,:,:,:,:,:,:)
10291 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
10292 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
10293 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
10294 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
10295
10296
10297 continue
10298 if (present(negative_support)) then
10299 negative_support_on = negative_support
10300 else
10301 negative_support_on = .true.
10302 end if
10303
10304 err_flag = .false.
10305
10306
10307 answer_shape = shape(answer)
10308 check_shape = shape(check)
10309
10310 consist_shape = answer_shape == check_shape
10311
10312 if (.not. all(consist_shape)) then
10313 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10314 write(*,*) ''
10315 write(*,*) ' shape of check is (', check_shape, ')'
10316 write(*,*) ' is INCORRECT'
10317 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10318
10319 call abortprogram('')
10320 end if
10321
10322
10323 allocate( mask_array( &
10324 & answer_shape(1), &
10325
10326 & answer_shape(2), &
10327
10328 & answer_shape(3), &
10329
10330 & answer_shape(4), &
10331
10332 & answer_shape(5), &
10333
10334 & answer_shape(6), &
10335
10336 & answer_shape(7) ) &
10337 & )
10338
10339 allocate( judge( &
10340 & answer_shape(1), &
10341
10342 & answer_shape(2), &
10343
10344 & answer_shape(3), &
10345
10346 & answer_shape(4), &
10347
10348 & answer_shape(5), &
10349
10350 & answer_shape(6), &
10351
10352 & answer_shape(7) ) &
10353 & )
10354
10355 allocate( judge_rev( &
10356 & answer_shape(1), &
10357
10358 & answer_shape(2), &
10359
10360 & answer_shape(3), &
10361
10362 & answer_shape(4), &
10363
10364 & answer_shape(5), &
10365
10366 & answer_shape(6), &
10367
10368 & answer_shape(7) ) &
10369 & )
10370
10371 allocate( answer_negative( &
10372 & answer_shape(1), &
10373
10374 & answer_shape(2), &
10375
10376 & answer_shape(3), &
10377
10378 & answer_shape(4), &
10379
10380 & answer_shape(5), &
10381
10382 & answer_shape(6), &
10383
10384 & answer_shape(7) ) &
10385 & )
10386
10387 allocate( check_negative( &
10388 & answer_shape(1), &
10389
10390 & answer_shape(2), &
10391
10392 & answer_shape(3), &
10393
10394 & answer_shape(4), &
10395
10396 & answer_shape(5), &
10397
10398 & answer_shape(6), &
10399
10400 & answer_shape(7) ) &
10401 & )
10402
10403 allocate( both_negative( &
10404 & answer_shape(1), &
10405
10406 & answer_shape(2), &
10407
10408 & answer_shape(3), &
10409
10410 & answer_shape(4), &
10411
10412 & answer_shape(5), &
10413
10414 & answer_shape(6), &
10415
10416 & answer_shape(7) ) &
10417 & )
10418
10419 answer_negative = answer < 0
10420 check_negative = check < 0
10421 both_negative = answer_negative .and. check_negative
10422 if (.not. negative_support_on) both_negative = .false.
10423
10424 judge = answer < check
10425 where (both_negative) judge = .not. judge
10426
10427 judge_rev = .not. judge
10428 err_flag = any(judge_rev)
10429 mask_array = 1
10430 pos = maxloc(mask_array, judge_rev)
10431
10432 if (err_flag) then
10433
10434 wrong = check( &
10435 & pos(1), &
10436
10437 & pos(2), &
10438
10439 & pos(3), &
10440
10441 & pos(4), &
10442
10443 & pos(5), &
10444
10445 & pos(6), &
10446
10447 & pos(7) )
10448
10449 right = answer( &
10450 & pos(1), &
10451
10452 & pos(2), &
10453
10454 & pos(3), &
10455
10456 & pos(4), &
10457
10458 & pos(5), &
10459
10460 & pos(6), &
10461
10462 & pos(7) )
10463
10464 write(unit=pos_array(1), fmt="(i20)") pos(1)
10465
10466 write(unit=pos_array(2), fmt="(i20)") pos(2)
10467
10468 write(unit=pos_array(3), fmt="(i20)") pos(3)
10469
10470 write(unit=pos_array(4), fmt="(i20)") pos(4)
10471
10472 write(unit=pos_array(5), fmt="(i20)") pos(5)
10473
10474 write(unit=pos_array(6), fmt="(i20)") pos(6)
10475
10476 write(unit=pos_array(7), fmt="(i20)") pos(7)
10477
10478
10479 pos_str = '(' // &
10480 & trim(adjustl(pos_array(1))) // ',' // &
10481
10482 & trim(adjustl(pos_array(2))) // ',' // &
10483
10484 & trim(adjustl(pos_array(3))) // ',' // &
10485
10486 & trim(adjustl(pos_array(4))) // ',' // &
10487
10488 & trim(adjustl(pos_array(5))) // ',' // &
10489
10490 & trim(adjustl(pos_array(6))) // ',' // &
10491
10492 & trim(adjustl(pos_array(7))) // ')'
10493
10494 if ( both_negative( &
10495 & pos(1), &
10496
10497 & pos(2), &
10498
10499 & pos(3), &
10500
10501 & pos(4), &
10502
10503 & pos(5), &
10504
10505 & pos(6), &
10506
10507 & pos(7) ) ) then
10508
10509 abs_mes = 'ABSOLUTE value of'
10510 else
10511 abs_mes = ''
10512
10513 end if
10514
10515 end if
10516 deallocate(mask_array, judge, judge_rev)
10517 deallocate(answer_negative, check_negative, both_negative)
10518
10519
10520
10521
10522 if (err_flag) then
10523 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10524 write(*,*) ''
10525 write(*,*) ' ' // trim(abs_mes) // &
10526 & ' check' // trim(pos_str) // ' = ', wrong
10527 write(*,*) ' is NOT GREATER THAN'
10528 write(*,*) ' ' // trim(abs_mes) // &
10529 & ' answer' // trim(pos_str) // ' = ', right
10530
10531 call abortprogram('')
10532 else
10533 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10534 end if
10535
10536

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal0()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal0 ( character(*), intent(in)  message,
real, intent(in)  answer,
real, intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10540 of file dc_test.f90.

10542 use sysdep, only: abortprogram
10543 use dc_types, only: string, token
10544 implicit none
10545 character(*), intent(in):: message
10546 real, intent(in):: answer
10547 real, intent(in):: check
10548 logical, intent(in), optional:: negative_support
10549 logical:: err_flag
10550 logical:: negative_support_on
10551 character(STRING):: pos_str
10552 character(TOKEN):: abs_mes
10553 real:: wrong, right
10554
10555
10556
10557 continue
10558 if (present(negative_support)) then
10559 negative_support_on = negative_support
10560 else
10561 negative_support_on = .true.
10562 end if
10563
10564 err_flag = .false.
10565
10566
10567 err_flag = .not. answer < check
10568 abs_mes = ''
10569
10570 if ( answer < 0.0 &
10571 & .and. check < 0.0 &
10572 & .and. negative_support_on ) then
10573
10574 err_flag = .not. err_flag
10575 abs_mes = 'ABSOLUTE value of'
10576 end if
10577
10578 wrong = check
10579 right = answer
10580 pos_str = ''
10581
10582
10583
10584
10585 if (err_flag) then
10586 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10587 write(*,*) ''
10588 write(*,*) ' ' // trim(abs_mes) // &
10589 & ' check' // trim(pos_str) // ' = ', wrong
10590 write(*,*) ' is NOT GREATER THAN'
10591 write(*,*) ' ' // trim(abs_mes) // &
10592 & ' answer' // trim(pos_str) // ' = ', right
10593
10594 call abortprogram('')
10595 else
10596 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10597 end if
10598
10599

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal1()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal1 ( character(*), intent(in)  message,
real, dimension(:), intent(in)  answer,
real, dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10603 of file dc_test.f90.

10605 use sysdep, only: abortprogram
10606 use dc_types, only: string, token
10607 implicit none
10608 character(*), intent(in):: message
10609 real, intent(in):: answer(:)
10610 real, intent(in):: check(:)
10611 logical, intent(in), optional:: negative_support
10612 logical:: err_flag
10613 logical:: negative_support_on
10614 character(STRING):: pos_str
10615 character(TOKEN):: abs_mes
10616 real:: wrong, right
10617
10618 integer:: answer_shape(1), check_shape(1), pos(1)
10619 logical:: consist_shape(1)
10620 character(TOKEN):: pos_array(1)
10621 integer, allocatable:: mask_array(:)
10622 logical, allocatable:: judge(:)
10623 logical, allocatable:: judge_rev(:)
10624 logical, allocatable:: answer_negative(:)
10625 logical, allocatable:: check_negative(:)
10626 logical, allocatable:: both_negative(:)
10627
10628
10629 continue
10630 if (present(negative_support)) then
10631 negative_support_on = negative_support
10632 else
10633 negative_support_on = .true.
10634 end if
10635
10636 err_flag = .false.
10637
10638
10639 answer_shape = shape(answer)
10640 check_shape = shape(check)
10641
10642 consist_shape = answer_shape == check_shape
10643
10644 if (.not. all(consist_shape)) then
10645 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10646 write(*,*) ''
10647 write(*,*) ' shape of check is (', check_shape, ')'
10648 write(*,*) ' is INCORRECT'
10649 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10650
10651 call abortprogram('')
10652 end if
10653
10654
10655 allocate( mask_array( &
10656
10657 & answer_shape(1) ) &
10658 & )
10659
10660 allocate( judge( &
10661
10662 & answer_shape(1) ) &
10663 & )
10664
10665 allocate( judge_rev( &
10666
10667 & answer_shape(1) ) &
10668 & )
10669
10670 allocate( answer_negative( &
10671
10672 & answer_shape(1) ) &
10673 & )
10674
10675 allocate( check_negative( &
10676
10677 & answer_shape(1) ) &
10678 & )
10679
10680 allocate( both_negative( &
10681
10682 & answer_shape(1) ) &
10683 & )
10684
10685 answer_negative = answer < 0.0
10686 check_negative = check < 0.0
10687 both_negative = answer_negative .and. check_negative
10688 if (.not. negative_support_on) both_negative = .false.
10689
10690 judge = answer < check
10691 where (both_negative) judge = .not. judge
10692
10693 judge_rev = .not. judge
10694 err_flag = any(judge_rev)
10695 mask_array = 1
10696 pos = maxloc(mask_array, judge_rev)
10697
10698 if (err_flag) then
10699
10700 wrong = check( &
10701
10702 & pos(1) )
10703
10704 right = answer( &
10705
10706 & pos(1) )
10707
10708 write(unit=pos_array(1), fmt="(i20)") pos(1)
10709
10710
10711 pos_str = '(' // &
10712
10713 & trim(adjustl(pos_array(1))) // ')'
10714
10715 if ( both_negative( &
10716
10717 & pos(1) ) ) then
10718
10719 abs_mes = 'ABSOLUTE value of'
10720 else
10721 abs_mes = ''
10722
10723 end if
10724
10725 end if
10726 deallocate(mask_array, judge, judge_rev)
10727 deallocate(answer_negative, check_negative, both_negative)
10728
10729
10730
10731
10732 if (err_flag) then
10733 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10734 write(*,*) ''
10735 write(*,*) ' ' // trim(abs_mes) // &
10736 & ' check' // trim(pos_str) // ' = ', wrong
10737 write(*,*) ' is NOT GREATER THAN'
10738 write(*,*) ' ' // trim(abs_mes) // &
10739 & ' answer' // trim(pos_str) // ' = ', right
10740
10741 call abortprogram('')
10742 else
10743 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10744 end if
10745
10746

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal2()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal2 ( character(*), intent(in)  message,
real, dimension(:,:), intent(in)  answer,
real, dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10750 of file dc_test.f90.

10752 use sysdep, only: abortprogram
10753 use dc_types, only: string, token
10754 implicit none
10755 character(*), intent(in):: message
10756 real, intent(in):: answer(:,:)
10757 real, intent(in):: check(:,:)
10758 logical, intent(in), optional:: negative_support
10759 logical:: err_flag
10760 logical:: negative_support_on
10761 character(STRING):: pos_str
10762 character(TOKEN):: abs_mes
10763 real:: wrong, right
10764
10765 integer:: answer_shape(2), check_shape(2), pos(2)
10766 logical:: consist_shape(2)
10767 character(TOKEN):: pos_array(2)
10768 integer, allocatable:: mask_array(:,:)
10769 logical, allocatable:: judge(:,:)
10770 logical, allocatable:: judge_rev(:,:)
10771 logical, allocatable:: answer_negative(:,:)
10772 logical, allocatable:: check_negative(:,:)
10773 logical, allocatable:: both_negative(:,:)
10774
10775
10776 continue
10777 if (present(negative_support)) then
10778 negative_support_on = negative_support
10779 else
10780 negative_support_on = .true.
10781 end if
10782
10783 err_flag = .false.
10784
10785
10786 answer_shape = shape(answer)
10787 check_shape = shape(check)
10788
10789 consist_shape = answer_shape == check_shape
10790
10791 if (.not. all(consist_shape)) then
10792 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10793 write(*,*) ''
10794 write(*,*) ' shape of check is (', check_shape, ')'
10795 write(*,*) ' is INCORRECT'
10796 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10797
10798 call abortprogram('')
10799 end if
10800
10801
10802 allocate( mask_array( &
10803 & answer_shape(1), &
10804
10805 & answer_shape(2) ) &
10806 & )
10807
10808 allocate( judge( &
10809 & answer_shape(1), &
10810
10811 & answer_shape(2) ) &
10812 & )
10813
10814 allocate( judge_rev( &
10815 & answer_shape(1), &
10816
10817 & answer_shape(2) ) &
10818 & )
10819
10820 allocate( answer_negative( &
10821 & answer_shape(1), &
10822
10823 & answer_shape(2) ) &
10824 & )
10825
10826 allocate( check_negative( &
10827 & answer_shape(1), &
10828
10829 & answer_shape(2) ) &
10830 & )
10831
10832 allocate( both_negative( &
10833 & answer_shape(1), &
10834
10835 & answer_shape(2) ) &
10836 & )
10837
10838 answer_negative = answer < 0.0
10839 check_negative = check < 0.0
10840 both_negative = answer_negative .and. check_negative
10841 if (.not. negative_support_on) both_negative = .false.
10842
10843 judge = answer < check
10844 where (both_negative) judge = .not. judge
10845
10846 judge_rev = .not. judge
10847 err_flag = any(judge_rev)
10848 mask_array = 1
10849 pos = maxloc(mask_array, judge_rev)
10850
10851 if (err_flag) then
10852
10853 wrong = check( &
10854 & pos(1), &
10855
10856 & pos(2) )
10857
10858 right = answer( &
10859 & pos(1), &
10860
10861 & pos(2) )
10862
10863 write(unit=pos_array(1), fmt="(i20)") pos(1)
10864
10865 write(unit=pos_array(2), fmt="(i20)") pos(2)
10866
10867
10868 pos_str = '(' // &
10869 & trim(adjustl(pos_array(1))) // ',' // &
10870
10871 & trim(adjustl(pos_array(2))) // ')'
10872
10873 if ( both_negative( &
10874 & pos(1), &
10875
10876 & pos(2) ) ) then
10877
10878 abs_mes = 'ABSOLUTE value of'
10879 else
10880 abs_mes = ''
10881
10882 end if
10883
10884 end if
10885 deallocate(mask_array, judge, judge_rev)
10886 deallocate(answer_negative, check_negative, both_negative)
10887
10888
10889
10890
10891 if (err_flag) then
10892 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10893 write(*,*) ''
10894 write(*,*) ' ' // trim(abs_mes) // &
10895 & ' check' // trim(pos_str) // ' = ', wrong
10896 write(*,*) ' is NOT GREATER THAN'
10897 write(*,*) ' ' // trim(abs_mes) // &
10898 & ' answer' // trim(pos_str) // ' = ', right
10899
10900 call abortprogram('')
10901 else
10902 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10903 end if
10904
10905

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal3()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal3 ( character(*), intent(in)  message,
real, dimension(:,:,:), intent(in)  answer,
real, dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10909 of file dc_test.f90.

10911 use sysdep, only: abortprogram
10912 use dc_types, only: string, token
10913 implicit none
10914 character(*), intent(in):: message
10915 real, intent(in):: answer(:,:,:)
10916 real, intent(in):: check(:,:,:)
10917 logical, intent(in), optional:: negative_support
10918 logical:: err_flag
10919 logical:: negative_support_on
10920 character(STRING):: pos_str
10921 character(TOKEN):: abs_mes
10922 real:: wrong, right
10923
10924 integer:: answer_shape(3), check_shape(3), pos(3)
10925 logical:: consist_shape(3)
10926 character(TOKEN):: pos_array(3)
10927 integer, allocatable:: mask_array(:,:,:)
10928 logical, allocatable:: judge(:,:,:)
10929 logical, allocatable:: judge_rev(:,:,:)
10930 logical, allocatable:: answer_negative(:,:,:)
10931 logical, allocatable:: check_negative(:,:,:)
10932 logical, allocatable:: both_negative(:,:,:)
10933
10934
10935 continue
10936 if (present(negative_support)) then
10937 negative_support_on = negative_support
10938 else
10939 negative_support_on = .true.
10940 end if
10941
10942 err_flag = .false.
10943
10944
10945 answer_shape = shape(answer)
10946 check_shape = shape(check)
10947
10948 consist_shape = answer_shape == check_shape
10949
10950 if (.not. all(consist_shape)) then
10951 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10952 write(*,*) ''
10953 write(*,*) ' shape of check is (', check_shape, ')'
10954 write(*,*) ' is INCORRECT'
10955 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10956
10957 call abortprogram('')
10958 end if
10959
10960
10961 allocate( mask_array( &
10962 & answer_shape(1), &
10963
10964 & answer_shape(2), &
10965
10966 & answer_shape(3) ) &
10967 & )
10968
10969 allocate( judge( &
10970 & answer_shape(1), &
10971
10972 & answer_shape(2), &
10973
10974 & answer_shape(3) ) &
10975 & )
10976
10977 allocate( judge_rev( &
10978 & answer_shape(1), &
10979
10980 & answer_shape(2), &
10981
10982 & answer_shape(3) ) &
10983 & )
10984
10985 allocate( answer_negative( &
10986 & answer_shape(1), &
10987
10988 & answer_shape(2), &
10989
10990 & answer_shape(3) ) &
10991 & )
10992
10993 allocate( check_negative( &
10994 & answer_shape(1), &
10995
10996 & answer_shape(2), &
10997
10998 & answer_shape(3) ) &
10999 & )
11000
11001 allocate( both_negative( &
11002 & answer_shape(1), &
11003
11004 & answer_shape(2), &
11005
11006 & answer_shape(3) ) &
11007 & )
11008
11009 answer_negative = answer < 0.0
11010 check_negative = check < 0.0
11011 both_negative = answer_negative .and. check_negative
11012 if (.not. negative_support_on) both_negative = .false.
11013
11014 judge = answer < check
11015 where (both_negative) judge = .not. judge
11016
11017 judge_rev = .not. judge
11018 err_flag = any(judge_rev)
11019 mask_array = 1
11020 pos = maxloc(mask_array, judge_rev)
11021
11022 if (err_flag) then
11023
11024 wrong = check( &
11025 & pos(1), &
11026
11027 & pos(2), &
11028
11029 & pos(3) )
11030
11031 right = answer( &
11032 & pos(1), &
11033
11034 & pos(2), &
11035
11036 & pos(3) )
11037
11038 write(unit=pos_array(1), fmt="(i20)") pos(1)
11039
11040 write(unit=pos_array(2), fmt="(i20)") pos(2)
11041
11042 write(unit=pos_array(3), fmt="(i20)") pos(3)
11043
11044
11045 pos_str = '(' // &
11046 & trim(adjustl(pos_array(1))) // ',' // &
11047
11048 & trim(adjustl(pos_array(2))) // ',' // &
11049
11050 & trim(adjustl(pos_array(3))) // ')'
11051
11052 if ( both_negative( &
11053 & pos(1), &
11054
11055 & pos(2), &
11056
11057 & pos(3) ) ) then
11058
11059 abs_mes = 'ABSOLUTE value of'
11060 else
11061 abs_mes = ''
11062
11063 end if
11064
11065 end if
11066 deallocate(mask_array, judge, judge_rev)
11067 deallocate(answer_negative, check_negative, both_negative)
11068
11069
11070
11071
11072 if (err_flag) then
11073 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11074 write(*,*) ''
11075 write(*,*) ' ' // trim(abs_mes) // &
11076 & ' check' // trim(pos_str) // ' = ', wrong
11077 write(*,*) ' is NOT GREATER THAN'
11078 write(*,*) ' ' // trim(abs_mes) // &
11079 & ' answer' // trim(pos_str) // ' = ', right
11080
11081 call abortprogram('')
11082 else
11083 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11084 end if
11085
11086

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal4()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal4 ( character(*), intent(in)  message,
real, dimension(:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11090 of file dc_test.f90.

11092 use sysdep, only: abortprogram
11093 use dc_types, only: string, token
11094 implicit none
11095 character(*), intent(in):: message
11096 real, intent(in):: answer(:,:,:,:)
11097 real, intent(in):: check(:,:,:,:)
11098 logical, intent(in), optional:: negative_support
11099 logical:: err_flag
11100 logical:: negative_support_on
11101 character(STRING):: pos_str
11102 character(TOKEN):: abs_mes
11103 real:: wrong, right
11104
11105 integer:: answer_shape(4), check_shape(4), pos(4)
11106 logical:: consist_shape(4)
11107 character(TOKEN):: pos_array(4)
11108 integer, allocatable:: mask_array(:,:,:,:)
11109 logical, allocatable:: judge(:,:,:,:)
11110 logical, allocatable:: judge_rev(:,:,:,:)
11111 logical, allocatable:: answer_negative(:,:,:,:)
11112 logical, allocatable:: check_negative(:,:,:,:)
11113 logical, allocatable:: both_negative(:,:,:,:)
11114
11115
11116 continue
11117 if (present(negative_support)) then
11118 negative_support_on = negative_support
11119 else
11120 negative_support_on = .true.
11121 end if
11122
11123 err_flag = .false.
11124
11125
11126 answer_shape = shape(answer)
11127 check_shape = shape(check)
11128
11129 consist_shape = answer_shape == check_shape
11130
11131 if (.not. all(consist_shape)) then
11132 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11133 write(*,*) ''
11134 write(*,*) ' shape of check is (', check_shape, ')'
11135 write(*,*) ' is INCORRECT'
11136 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11137
11138 call abortprogram('')
11139 end if
11140
11141
11142 allocate( mask_array( &
11143 & answer_shape(1), &
11144
11145 & answer_shape(2), &
11146
11147 & answer_shape(3), &
11148
11149 & answer_shape(4) ) &
11150 & )
11151
11152 allocate( judge( &
11153 & answer_shape(1), &
11154
11155 & answer_shape(2), &
11156
11157 & answer_shape(3), &
11158
11159 & answer_shape(4) ) &
11160 & )
11161
11162 allocate( judge_rev( &
11163 & answer_shape(1), &
11164
11165 & answer_shape(2), &
11166
11167 & answer_shape(3), &
11168
11169 & answer_shape(4) ) &
11170 & )
11171
11172 allocate( answer_negative( &
11173 & answer_shape(1), &
11174
11175 & answer_shape(2), &
11176
11177 & answer_shape(3), &
11178
11179 & answer_shape(4) ) &
11180 & )
11181
11182 allocate( check_negative( &
11183 & answer_shape(1), &
11184
11185 & answer_shape(2), &
11186
11187 & answer_shape(3), &
11188
11189 & answer_shape(4) ) &
11190 & )
11191
11192 allocate( both_negative( &
11193 & answer_shape(1), &
11194
11195 & answer_shape(2), &
11196
11197 & answer_shape(3), &
11198
11199 & answer_shape(4) ) &
11200 & )
11201
11202 answer_negative = answer < 0.0
11203 check_negative = check < 0.0
11204 both_negative = answer_negative .and. check_negative
11205 if (.not. negative_support_on) both_negative = .false.
11206
11207 judge = answer < check
11208 where (both_negative) judge = .not. judge
11209
11210 judge_rev = .not. judge
11211 err_flag = any(judge_rev)
11212 mask_array = 1
11213 pos = maxloc(mask_array, judge_rev)
11214
11215 if (err_flag) then
11216
11217 wrong = check( &
11218 & pos(1), &
11219
11220 & pos(2), &
11221
11222 & pos(3), &
11223
11224 & pos(4) )
11225
11226 right = answer( &
11227 & pos(1), &
11228
11229 & pos(2), &
11230
11231 & pos(3), &
11232
11233 & pos(4) )
11234
11235 write(unit=pos_array(1), fmt="(i20)") pos(1)
11236
11237 write(unit=pos_array(2), fmt="(i20)") pos(2)
11238
11239 write(unit=pos_array(3), fmt="(i20)") pos(3)
11240
11241 write(unit=pos_array(4), fmt="(i20)") pos(4)
11242
11243
11244 pos_str = '(' // &
11245 & trim(adjustl(pos_array(1))) // ',' // &
11246
11247 & trim(adjustl(pos_array(2))) // ',' // &
11248
11249 & trim(adjustl(pos_array(3))) // ',' // &
11250
11251 & trim(adjustl(pos_array(4))) // ')'
11252
11253 if ( both_negative( &
11254 & pos(1), &
11255
11256 & pos(2), &
11257
11258 & pos(3), &
11259
11260 & pos(4) ) ) then
11261
11262 abs_mes = 'ABSOLUTE value of'
11263 else
11264 abs_mes = ''
11265
11266 end if
11267
11268 end if
11269 deallocate(mask_array, judge, judge_rev)
11270 deallocate(answer_negative, check_negative, both_negative)
11271
11272
11273
11274
11275 if (err_flag) then
11276 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11277 write(*,*) ''
11278 write(*,*) ' ' // trim(abs_mes) // &
11279 & ' check' // trim(pos_str) // ' = ', wrong
11280 write(*,*) ' is NOT GREATER THAN'
11281 write(*,*) ' ' // trim(abs_mes) // &
11282 & ' answer' // trim(pos_str) // ' = ', right
11283
11284 call abortprogram('')
11285 else
11286 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11287 end if
11288
11289

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal5()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal5 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11293 of file dc_test.f90.

11295 use sysdep, only: abortprogram
11296 use dc_types, only: string, token
11297 implicit none
11298 character(*), intent(in):: message
11299 real, intent(in):: answer(:,:,:,:,:)
11300 real, intent(in):: check(:,:,:,:,:)
11301 logical, intent(in), optional:: negative_support
11302 logical:: err_flag
11303 logical:: negative_support_on
11304 character(STRING):: pos_str
11305 character(TOKEN):: abs_mes
11306 real:: wrong, right
11307
11308 integer:: answer_shape(5), check_shape(5), pos(5)
11309 logical:: consist_shape(5)
11310 character(TOKEN):: pos_array(5)
11311 integer, allocatable:: mask_array(:,:,:,:,:)
11312 logical, allocatable:: judge(:,:,:,:,:)
11313 logical, allocatable:: judge_rev(:,:,:,:,:)
11314 logical, allocatable:: answer_negative(:,:,:,:,:)
11315 logical, allocatable:: check_negative(:,:,:,:,:)
11316 logical, allocatable:: both_negative(:,:,:,:,:)
11317
11318
11319 continue
11320 if (present(negative_support)) then
11321 negative_support_on = negative_support
11322 else
11323 negative_support_on = .true.
11324 end if
11325
11326 err_flag = .false.
11327
11328
11329 answer_shape = shape(answer)
11330 check_shape = shape(check)
11331
11332 consist_shape = answer_shape == check_shape
11333
11334 if (.not. all(consist_shape)) then
11335 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11336 write(*,*) ''
11337 write(*,*) ' shape of check is (', check_shape, ')'
11338 write(*,*) ' is INCORRECT'
11339 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11340
11341 call abortprogram('')
11342 end if
11343
11344
11345 allocate( mask_array( &
11346 & answer_shape(1), &
11347
11348 & answer_shape(2), &
11349
11350 & answer_shape(3), &
11351
11352 & answer_shape(4), &
11353
11354 & answer_shape(5) ) &
11355 & )
11356
11357 allocate( judge( &
11358 & answer_shape(1), &
11359
11360 & answer_shape(2), &
11361
11362 & answer_shape(3), &
11363
11364 & answer_shape(4), &
11365
11366 & answer_shape(5) ) &
11367 & )
11368
11369 allocate( judge_rev( &
11370 & answer_shape(1), &
11371
11372 & answer_shape(2), &
11373
11374 & answer_shape(3), &
11375
11376 & answer_shape(4), &
11377
11378 & answer_shape(5) ) &
11379 & )
11380
11381 allocate( answer_negative( &
11382 & answer_shape(1), &
11383
11384 & answer_shape(2), &
11385
11386 & answer_shape(3), &
11387
11388 & answer_shape(4), &
11389
11390 & answer_shape(5) ) &
11391 & )
11392
11393 allocate( check_negative( &
11394 & answer_shape(1), &
11395
11396 & answer_shape(2), &
11397
11398 & answer_shape(3), &
11399
11400 & answer_shape(4), &
11401
11402 & answer_shape(5) ) &
11403 & )
11404
11405 allocate( both_negative( &
11406 & answer_shape(1), &
11407
11408 & answer_shape(2), &
11409
11410 & answer_shape(3), &
11411
11412 & answer_shape(4), &
11413
11414 & answer_shape(5) ) &
11415 & )
11416
11417 answer_negative = answer < 0.0
11418 check_negative = check < 0.0
11419 both_negative = answer_negative .and. check_negative
11420 if (.not. negative_support_on) both_negative = .false.
11421
11422 judge = answer < check
11423 where (both_negative) judge = .not. judge
11424
11425 judge_rev = .not. judge
11426 err_flag = any(judge_rev)
11427 mask_array = 1
11428 pos = maxloc(mask_array, judge_rev)
11429
11430 if (err_flag) then
11431
11432 wrong = check( &
11433 & pos(1), &
11434
11435 & pos(2), &
11436
11437 & pos(3), &
11438
11439 & pos(4), &
11440
11441 & pos(5) )
11442
11443 right = answer( &
11444 & pos(1), &
11445
11446 & pos(2), &
11447
11448 & pos(3), &
11449
11450 & pos(4), &
11451
11452 & pos(5) )
11453
11454 write(unit=pos_array(1), fmt="(i20)") pos(1)
11455
11456 write(unit=pos_array(2), fmt="(i20)") pos(2)
11457
11458 write(unit=pos_array(3), fmt="(i20)") pos(3)
11459
11460 write(unit=pos_array(4), fmt="(i20)") pos(4)
11461
11462 write(unit=pos_array(5), fmt="(i20)") pos(5)
11463
11464
11465 pos_str = '(' // &
11466 & trim(adjustl(pos_array(1))) // ',' // &
11467
11468 & trim(adjustl(pos_array(2))) // ',' // &
11469
11470 & trim(adjustl(pos_array(3))) // ',' // &
11471
11472 & trim(adjustl(pos_array(4))) // ',' // &
11473
11474 & trim(adjustl(pos_array(5))) // ')'
11475
11476 if ( both_negative( &
11477 & pos(1), &
11478
11479 & pos(2), &
11480
11481 & pos(3), &
11482
11483 & pos(4), &
11484
11485 & pos(5) ) ) then
11486
11487 abs_mes = 'ABSOLUTE value of'
11488 else
11489 abs_mes = ''
11490
11491 end if
11492
11493 end if
11494 deallocate(mask_array, judge, judge_rev)
11495 deallocate(answer_negative, check_negative, both_negative)
11496
11497
11498
11499
11500 if (err_flag) then
11501 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11502 write(*,*) ''
11503 write(*,*) ' ' // trim(abs_mes) // &
11504 & ' check' // trim(pos_str) // ' = ', wrong
11505 write(*,*) ' is NOT GREATER THAN'
11506 write(*,*) ' ' // trim(abs_mes) // &
11507 & ' answer' // trim(pos_str) // ' = ', right
11508
11509 call abortprogram('')
11510 else
11511 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11512 end if
11513
11514

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal6()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal6 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11518 of file dc_test.f90.

11520 use sysdep, only: abortprogram
11521 use dc_types, only: string, token
11522 implicit none
11523 character(*), intent(in):: message
11524 real, intent(in):: answer(:,:,:,:,:,:)
11525 real, intent(in):: check(:,:,:,:,:,:)
11526 logical, intent(in), optional:: negative_support
11527 logical:: err_flag
11528 logical:: negative_support_on
11529 character(STRING):: pos_str
11530 character(TOKEN):: abs_mes
11531 real:: wrong, right
11532
11533 integer:: answer_shape(6), check_shape(6), pos(6)
11534 logical:: consist_shape(6)
11535 character(TOKEN):: pos_array(6)
11536 integer, allocatable:: mask_array(:,:,:,:,:,:)
11537 logical, allocatable:: judge(:,:,:,:,:,:)
11538 logical, allocatable:: judge_rev(:,:,:,:,:,:)
11539 logical, allocatable:: answer_negative(:,:,:,:,:,:)
11540 logical, allocatable:: check_negative(:,:,:,:,:,:)
11541 logical, allocatable:: both_negative(:,:,:,:,:,:)
11542
11543
11544 continue
11545 if (present(negative_support)) then
11546 negative_support_on = negative_support
11547 else
11548 negative_support_on = .true.
11549 end if
11550
11551 err_flag = .false.
11552
11553
11554 answer_shape = shape(answer)
11555 check_shape = shape(check)
11556
11557 consist_shape = answer_shape == check_shape
11558
11559 if (.not. all(consist_shape)) then
11560 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11561 write(*,*) ''
11562 write(*,*) ' shape of check is (', check_shape, ')'
11563 write(*,*) ' is INCORRECT'
11564 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11565
11566 call abortprogram('')
11567 end if
11568
11569
11570 allocate( mask_array( &
11571 & answer_shape(1), &
11572
11573 & answer_shape(2), &
11574
11575 & answer_shape(3), &
11576
11577 & answer_shape(4), &
11578
11579 & answer_shape(5), &
11580
11581 & answer_shape(6) ) &
11582 & )
11583
11584 allocate( judge( &
11585 & answer_shape(1), &
11586
11587 & answer_shape(2), &
11588
11589 & answer_shape(3), &
11590
11591 & answer_shape(4), &
11592
11593 & answer_shape(5), &
11594
11595 & answer_shape(6) ) &
11596 & )
11597
11598 allocate( judge_rev( &
11599 & answer_shape(1), &
11600
11601 & answer_shape(2), &
11602
11603 & answer_shape(3), &
11604
11605 & answer_shape(4), &
11606
11607 & answer_shape(5), &
11608
11609 & answer_shape(6) ) &
11610 & )
11611
11612 allocate( answer_negative( &
11613 & answer_shape(1), &
11614
11615 & answer_shape(2), &
11616
11617 & answer_shape(3), &
11618
11619 & answer_shape(4), &
11620
11621 & answer_shape(5), &
11622
11623 & answer_shape(6) ) &
11624 & )
11625
11626 allocate( check_negative( &
11627 & answer_shape(1), &
11628
11629 & answer_shape(2), &
11630
11631 & answer_shape(3), &
11632
11633 & answer_shape(4), &
11634
11635 & answer_shape(5), &
11636
11637 & answer_shape(6) ) &
11638 & )
11639
11640 allocate( both_negative( &
11641 & answer_shape(1), &
11642
11643 & answer_shape(2), &
11644
11645 & answer_shape(3), &
11646
11647 & answer_shape(4), &
11648
11649 & answer_shape(5), &
11650
11651 & answer_shape(6) ) &
11652 & )
11653
11654 answer_negative = answer < 0.0
11655 check_negative = check < 0.0
11656 both_negative = answer_negative .and. check_negative
11657 if (.not. negative_support_on) both_negative = .false.
11658
11659 judge = answer < check
11660 where (both_negative) judge = .not. judge
11661
11662 judge_rev = .not. judge
11663 err_flag = any(judge_rev)
11664 mask_array = 1
11665 pos = maxloc(mask_array, judge_rev)
11666
11667 if (err_flag) then
11668
11669 wrong = check( &
11670 & pos(1), &
11671
11672 & pos(2), &
11673
11674 & pos(3), &
11675
11676 & pos(4), &
11677
11678 & pos(5), &
11679
11680 & pos(6) )
11681
11682 right = answer( &
11683 & pos(1), &
11684
11685 & pos(2), &
11686
11687 & pos(3), &
11688
11689 & pos(4), &
11690
11691 & pos(5), &
11692
11693 & pos(6) )
11694
11695 write(unit=pos_array(1), fmt="(i20)") pos(1)
11696
11697 write(unit=pos_array(2), fmt="(i20)") pos(2)
11698
11699 write(unit=pos_array(3), fmt="(i20)") pos(3)
11700
11701 write(unit=pos_array(4), fmt="(i20)") pos(4)
11702
11703 write(unit=pos_array(5), fmt="(i20)") pos(5)
11704
11705 write(unit=pos_array(6), fmt="(i20)") pos(6)
11706
11707
11708 pos_str = '(' // &
11709 & trim(adjustl(pos_array(1))) // ',' // &
11710
11711 & trim(adjustl(pos_array(2))) // ',' // &
11712
11713 & trim(adjustl(pos_array(3))) // ',' // &
11714
11715 & trim(adjustl(pos_array(4))) // ',' // &
11716
11717 & trim(adjustl(pos_array(5))) // ',' // &
11718
11719 & trim(adjustl(pos_array(6))) // ')'
11720
11721 if ( both_negative( &
11722 & pos(1), &
11723
11724 & pos(2), &
11725
11726 & pos(3), &
11727
11728 & pos(4), &
11729
11730 & pos(5), &
11731
11732 & pos(6) ) ) then
11733
11734 abs_mes = 'ABSOLUTE value of'
11735 else
11736 abs_mes = ''
11737
11738 end if
11739
11740 end if
11741 deallocate(mask_array, judge, judge_rev)
11742 deallocate(answer_negative, check_negative, both_negative)
11743
11744
11745
11746
11747 if (err_flag) then
11748 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11749 write(*,*) ''
11750 write(*,*) ' ' // trim(abs_mes) // &
11751 & ' check' // trim(pos_str) // ' = ', wrong
11752 write(*,*) ' is NOT GREATER THAN'
11753 write(*,*) ' ' // trim(abs_mes) // &
11754 & ' answer' // trim(pos_str) // ' = ', right
11755
11756 call abortprogram('')
11757 else
11758 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11759 end if
11760
11761

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertgreaterthanreal7()

subroutine dc_test::assertgreaterthan::dctestassertgreaterthanreal7 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11765 of file dc_test.f90.

11767 use sysdep, only: abortprogram
11768 use dc_types, only: string, token
11769 implicit none
11770 character(*), intent(in):: message
11771 real, intent(in):: answer(:,:,:,:,:,:,:)
11772 real, intent(in):: check(:,:,:,:,:,:,:)
11773 logical, intent(in), optional:: negative_support
11774 logical:: err_flag
11775 logical:: negative_support_on
11776 character(STRING):: pos_str
11777 character(TOKEN):: abs_mes
11778 real:: wrong, right
11779
11780 integer:: answer_shape(7), check_shape(7), pos(7)
11781 logical:: consist_shape(7)
11782 character(TOKEN):: pos_array(7)
11783 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
11784 logical, allocatable:: judge(:,:,:,:,:,:,:)
11785 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
11786 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
11787 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
11788 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
11789
11790
11791 continue
11792 if (present(negative_support)) then
11793 negative_support_on = negative_support
11794 else
11795 negative_support_on = .true.
11796 end if
11797
11798 err_flag = .false.
11799
11800
11801 answer_shape = shape(answer)
11802 check_shape = shape(check)
11803
11804 consist_shape = answer_shape == check_shape
11805
11806 if (.not. all(consist_shape)) then
11807 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11808 write(*,*) ''
11809 write(*,*) ' shape of check is (', check_shape, ')'
11810 write(*,*) ' is INCORRECT'
11811 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11812
11813 call abortprogram('')
11814 end if
11815
11816
11817 allocate( mask_array( &
11818 & answer_shape(1), &
11819
11820 & answer_shape(2), &
11821
11822 & answer_shape(3), &
11823
11824 & answer_shape(4), &
11825
11826 & answer_shape(5), &
11827
11828 & answer_shape(6), &
11829
11830 & answer_shape(7) ) &
11831 & )
11832
11833 allocate( judge( &
11834 & answer_shape(1), &
11835
11836 & answer_shape(2), &
11837
11838 & answer_shape(3), &
11839
11840 & answer_shape(4), &
11841
11842 & answer_shape(5), &
11843
11844 & answer_shape(6), &
11845
11846 & answer_shape(7) ) &
11847 & )
11848
11849 allocate( judge_rev( &
11850 & answer_shape(1), &
11851
11852 & answer_shape(2), &
11853
11854 & answer_shape(3), &
11855
11856 & answer_shape(4), &
11857
11858 & answer_shape(5), &
11859
11860 & answer_shape(6), &
11861
11862 & answer_shape(7) ) &
11863 & )
11864
11865 allocate( answer_negative( &
11866 & answer_shape(1), &
11867
11868 & answer_shape(2), &
11869
11870 & answer_shape(3), &
11871
11872 & answer_shape(4), &
11873
11874 & answer_shape(5), &
11875
11876 & answer_shape(6), &
11877
11878 & answer_shape(7) ) &
11879 & )
11880
11881 allocate( check_negative( &
11882 & answer_shape(1), &
11883
11884 & answer_shape(2), &
11885
11886 & answer_shape(3), &
11887
11888 & answer_shape(4), &
11889
11890 & answer_shape(5), &
11891
11892 & answer_shape(6), &
11893
11894 & answer_shape(7) ) &
11895 & )
11896
11897 allocate( both_negative( &
11898 & answer_shape(1), &
11899
11900 & answer_shape(2), &
11901
11902 & answer_shape(3), &
11903
11904 & answer_shape(4), &
11905
11906 & answer_shape(5), &
11907
11908 & answer_shape(6), &
11909
11910 & answer_shape(7) ) &
11911 & )
11912
11913 answer_negative = answer < 0.0
11914 check_negative = check < 0.0
11915 both_negative = answer_negative .and. check_negative
11916 if (.not. negative_support_on) both_negative = .false.
11917
11918 judge = answer < check
11919 where (both_negative) judge = .not. judge
11920
11921 judge_rev = .not. judge
11922 err_flag = any(judge_rev)
11923 mask_array = 1
11924 pos = maxloc(mask_array, judge_rev)
11925
11926 if (err_flag) then
11927
11928 wrong = check( &
11929 & pos(1), &
11930
11931 & pos(2), &
11932
11933 & pos(3), &
11934
11935 & pos(4), &
11936
11937 & pos(5), &
11938
11939 & pos(6), &
11940
11941 & pos(7) )
11942
11943 right = answer( &
11944 & pos(1), &
11945
11946 & pos(2), &
11947
11948 & pos(3), &
11949
11950 & pos(4), &
11951
11952 & pos(5), &
11953
11954 & pos(6), &
11955
11956 & pos(7) )
11957
11958 write(unit=pos_array(1), fmt="(i20)") pos(1)
11959
11960 write(unit=pos_array(2), fmt="(i20)") pos(2)
11961
11962 write(unit=pos_array(3), fmt="(i20)") pos(3)
11963
11964 write(unit=pos_array(4), fmt="(i20)") pos(4)
11965
11966 write(unit=pos_array(5), fmt="(i20)") pos(5)
11967
11968 write(unit=pos_array(6), fmt="(i20)") pos(6)
11969
11970 write(unit=pos_array(7), fmt="(i20)") pos(7)
11971
11972
11973 pos_str = '(' // &
11974 & trim(adjustl(pos_array(1))) // ',' // &
11975
11976 & trim(adjustl(pos_array(2))) // ',' // &
11977
11978 & trim(adjustl(pos_array(3))) // ',' // &
11979
11980 & trim(adjustl(pos_array(4))) // ',' // &
11981
11982 & trim(adjustl(pos_array(5))) // ',' // &
11983
11984 & trim(adjustl(pos_array(6))) // ',' // &
11985
11986 & trim(adjustl(pos_array(7))) // ')'
11987
11988 if ( both_negative( &
11989 & pos(1), &
11990
11991 & pos(2), &
11992
11993 & pos(3), &
11994
11995 & pos(4), &
11996
11997 & pos(5), &
11998
11999 & pos(6), &
12000
12001 & pos(7) ) ) then
12002
12003 abs_mes = 'ABSOLUTE value of'
12004 else
12005 abs_mes = ''
12006
12007 end if
12008
12009 end if
12010 deallocate(mask_array, judge, judge_rev)
12011 deallocate(answer_negative, check_negative, both_negative)
12012
12013
12014
12015
12016 if (err_flag) then
12017 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12018 write(*,*) ''
12019 write(*,*) ' ' // trim(abs_mes) // &
12020 & ' check' // trim(pos_str) // ' = ', wrong
12021 write(*,*) ' is NOT GREATER THAN'
12022 write(*,*) ' ' // trim(abs_mes) // &
12023 & ' answer' // trim(pos_str) // ' = ', right
12024
12025 call abortprogram('')
12026 else
12027 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12028 end if
12029
12030

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:
The documentation for this interface was generated from the following file:
Generated on Fri May 29 2026 05:34:32 for gtool5 Fortran 90/95 Library by doxygen 1.9.8