| ! { dg-do run } |
| ! |
| ! This test case is inserted as a check. PR89365 inially asserted that |
| ! gfortran was getting the bounds wrong for allocatable and pointer |
| ! actual arguments. However, the reporter accepted that it is OK and |
| ! this is the corrected version of his testcase, which fills a gap in |
| ! the testsuite. |
| ! |
| ! Contributed by Reinhold Bader <Bader@lrz.de> |
| ! |
| module mod_ass_rank_inquiry |
| use, intrinsic :: iso_c_binding |
| implicit none |
| logical, parameter :: debug = .true. |
| integer :: error_count = 0 |
| ! |
| ! using inquiry functions for assumed rank objects |
| ! |
| contains |
| subroutine foo_1(this) |
| real(c_float) :: this(..) |
| select case(rank(this)) |
| case(0) |
| if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & |
| size(ubound(this)) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape / lbound / ubound' |
| end if |
| if (size(this) /= 1) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size' |
| end if |
| case(1) |
| if (sum(abs(shape(this) - [4])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape' |
| end if |
| if (size(this) /= 4) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size', size(this) |
| end if |
| if (lbound(this,1) /= 1) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL lbound',lbound(this,1) |
| end if |
| if (ubound(this,1) /= 4) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL ubound',ubound(this,1) |
| end if |
| case(3) |
| if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape' |
| end if |
| if (size(this) /= 2*3*4) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size' |
| end if |
| if (sum(abs(lbound(this) - [ 1, 1, 1 ])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL lbound' |
| end if |
| if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL ubound' |
| end if |
| case default |
| error_count = error_count + 1 |
| end select |
| end subroutine foo_1 |
| subroutine foo_2(this) |
| real(c_float), allocatable :: this(..) |
| if (.not. allocated(this)) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL allocated' |
| end if |
| select case(rank(this)) |
| case(0) |
| if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & |
| size(ubound(this)) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape / lbound / ubound' |
| end if |
| if (size(this) /= 1) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size' |
| end if |
| case(1) |
| if (sum(abs(shape(this) - [4])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape' |
| end if |
| if (size(this) /= 4) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size', size(this) |
| end if |
| if (lbound(this,1) /= 2) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL lbound',lbound(this,1) |
| end if |
| if (ubound(this,1) /= 5) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL ubound',ubound(this,1) |
| end if |
| case(3) |
| if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape' |
| end if |
| if (size(this) /= 2*3*4) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size' |
| end if |
| if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL lbound', lbound(this) |
| end if |
| if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL ubound', ubound(this) |
| end if |
| case default |
| error_count = error_count + 1 |
| end select |
| end subroutine foo_2 |
| subroutine foo_3(this) |
| real(c_float), pointer :: this(..) |
| if (.not. associated(this)) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL associated' |
| end if |
| select case(rank(this)) |
| case(0) |
| if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & |
| size(ubound(this)) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape / lbound / ubound' |
| end if |
| if (size(this) /= 1) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size' |
| end if |
| case(1) |
| if (sum(abs(shape(this) - [4])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape' |
| end if |
| if (size(this) /= 4) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size', size(this) |
| end if |
| if (lbound(this,1) /= 2) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL lbound',lbound(this,1) |
| end if |
| if (ubound(this,1) /= 5) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL ubound',ubound(this,1) |
| end if |
| case(3) |
| if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL shape' |
| end if |
| if (size(this) /= 2*3*4) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL size' |
| end if |
| if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL lbound', lbound(this) |
| end if |
| if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then |
| error_count = error_count + 1 |
| if (debug) write(*,*) 'FAIL ubound', ubound(this) |
| end if |
| case default |
| error_count = error_count + 1 |
| end select |
| end subroutine foo_3 |
| end module mod_ass_rank_inquiry |
| program ass_rank_inquiry |
| use mod_ass_rank_inquiry |
| implicit none |
| real, allocatable :: x, y(:), z(:,:,:) |
| real, pointer :: xp, yp(:), zp(:,:,:) |
| |
| allocate(x, y(2:5), z(0:1,-1:1,1:4)) |
| allocate(xp, yp(2:5), zp(0:1,-1:1,1:4)) |
| |
| |
| call foo_1(x) |
| if (error_count > 0) write(*,*) 'FAIL: after scalar ',error_count |
| call foo_1(y) |
| if (error_count > 0) write(*,*) 'FAIL: after rank-1 ',error_count |
| call foo_1(z) |
| if (error_count > 0) write(*,*) 'FAIL: after rank-3 ',error_count |
| call foo_2(x) |
| if (error_count > 0) write(*,*) 'FAIL: after allocscalar ',error_count |
| call foo_2(y) |
| if (error_count > 0) write(*,*) 'FAIL: after allocrank-1 ',error_count |
| call foo_2(z) |
| if (error_count > 0) write(*,*) 'FAIL: after allocrank-3 ',error_count |
| call foo_3(xp) |
| if (error_count > 0) write(*,*) 'FAIL: after ptrscalar ',error_count |
| call foo_3(yp) |
| if (error_count > 0) write(*,*) 'FAIL: after ptrrank-1 ',error_count |
| call foo_3(zp) |
| if (error_count > 0) write(*,*) 'FAIL: after ptrrank-3 ',error_count |
| |
| if (error_count == 0) then |
| write(*,*) 'OK' |
| else |
| stop 1 |
| end if |
| |
| deallocate(x, y, z) |
| deallocate(xp, yp, zp) |
| end program ass_rank_inquiry |