| ! { dg-do run { target c99_runtime } } |
| ! { dg-additional-sources ISO_Fortran_binding_10.c } |
| ! |
| ! Test the fix of PR89843. |
| ! |
| ! Contributed by Reinhold Bader <Bader@lrz.de> |
| ! |
| module mod_section_01 |
| use, intrinsic :: iso_c_binding |
| implicit none |
| interface |
| subroutine si(this, flag, status) bind(c) |
| import :: c_float, c_int |
| real(c_float) :: this(:,:) |
| integer(c_int), value :: flag |
| integer(c_int) :: status |
| end subroutine si |
| end interface |
| contains |
| subroutine sa(this, flag, status) bind(c) |
| real(c_float) :: this(:) |
| integer(c_int), value :: flag |
| integer(c_int) :: status |
| |
| status = 0 |
| |
| select case (flag) |
| case (0) |
| if (is_contiguous(this)) then |
| write(*,*) 'FAIL 1:' |
| status = status + 1 |
| end if |
| if (size(this,1) /= 3) then |
| write(*,*) 'FAIL 2:',size(this) |
| status = status + 1 |
| goto 10 |
| end if |
| if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then |
| write(*,*) 'FAIL 3:',abs(this) |
| status = status + 1 |
| end if |
| 10 continue |
| case (1) |
| if (size(this,1) /= 3) then |
| write(*,*) 'FAIL 4:',size(this) |
| status = status + 1 |
| goto 20 |
| end if |
| if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then |
| write(*,*) 'FAIL 5:',this |
| status = status + 1 |
| end if |
| 20 continue |
| case (2) |
| if (size(this,1) /= 4) then |
| write(*,*) 'FAIL 6:',size(this) |
| status = status + 1 |
| goto 30 |
| end if |
| if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then |
| write(*,*) 'FAIL 7:',this |
| status = status + 1 |
| end if |
| 30 continue |
| end select |
| |
| ! if (status == 0) then |
| ! write(*,*) 'OK' |
| ! end if |
| end subroutine sa |
| end module mod_section_01 |
| |
| program section_01 |
| use mod_section_01 |
| implicit none |
| real(c_float) :: v(5,4) |
| integer :: i |
| integer :: status |
| |
| v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] ) |
| call si(v, 0, status) |
| if (status .ne. 0) stop 1 |
| |
| call sa(v(1:5:2, 1), 0, status) |
| if (status .ne. 0) stop 2 |
| |
| call si(v, 1, status) |
| if (status .ne. 0) stop 3 |
| |
| call sa(v(1:3, 3), 1, status) |
| if (status .ne. 0) stop 4 |
| |
| call si(v, 2, status) |
| if (status .ne. 0) stop 5 |
| |
| call sa(v(2,1:4), 2, status) |
| if (status .ne. 0) stop 6 |
| |
| end program section_01 |
