gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90

   1 ! { dg-do run { target c99_runtime } }
   2 ! { dg-additional-sources ISO_Fortran_binding_10.c }
   3 !
   4 ! Test the fix of PR89843.
   5 !
   6 ! Contributed by Reinhold Bader  <Bader@lrz.de>
   7 !
   8 module mod_section_01
   9   use, intrinsic :: iso_c_binding
  10   implicit none
  11   interface
  12      subroutine si(this, flag, status) bind(c)
  13        import :: c_float, c_int
  14        real(c_float) :: this(:,:)
  15        integer(c_int), value :: flag
  16        integer(c_int) :: status
  17      end subroutine si
  18   end interface
  19 contains
  20   subroutine sa(this, flag, status) bind(c)
  21     real(c_float) :: this(:)
  22     integer(c_int), value :: flag
  23     integer(c_int) :: status
  24
  25     status = 0
  26
  27     select case (flag)
  28     case (0)
  29        if (is_contiguous(this)) then
  30           write(*,*) 'FAIL 1:'
  31           status = status + 1
  32        end if
  33        if (size(this,1) /= 3) then
  34           write(*,*) 'FAIL 2:',size(this)
  35           status = status + 1
  36           goto 10
  37        end if
  38        if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then
  39           write(*,*) 'FAIL 3:',abs(this)
  40           status = status + 1
  41        end if
  42   10   continue
  43    case (1)
  44       if (size(this,1) /= 3) then
  45           write(*,*) 'FAIL 4:',size(this)
  46           status = status + 1
  47           goto 20
  48        end if
  49        if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then
  50           write(*,*) 'FAIL 5:',this
  51           status = status + 1
  52        end if
  53   20   continue
  54    case (2)
  55       if (size(this,1) /= 4) then
  56           write(*,*) 'FAIL 6:',size(this)
  57           status = status + 1
  58           goto 30
  59        end if
  60       if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then
  61           write(*,*) 'FAIL 7:',this
  62           status = status + 1
  63        end if
  64   30   continue
  65     end select
  66
  67 !    if (status == 0) then
  68 !       write(*,*) 'OK'
  69 !    end if
  70   end subroutine sa
  71 end module mod_section_01
  72
  73 program section_01
  74   use mod_section_01
  75   implicit none
  76   real(c_float) :: v(5,4)
  77   integer :: i
  78   integer :: status
  79
  80   v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] )
  81   call si(v, 0, status)
  82   if (status .ne. 0) stop 1
  83
  84   call sa(v(1:5:2, 1), 0, status)
  85   if (status .ne. 0) stop 2
  86
  87   call si(v, 1, status)
  88   if (status .ne. 0) stop 3
  89
  90   call sa(v(1:3, 3), 1, status)
  91   if (status .ne. 0) stop 4
  92
  93   call si(v, 2, status)
  94   if (status .ne. 0) stop 5
  95
  96   call sa(v(2,1:4), 2, status)
  97   if (status .ne. 0) stop 6
  98
  99 end program section_01