gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-2.f90

! { dg-do run }
!
! This program checks that passing arrays as assumed-rank dummies to
! and from Fortran functions with C binding works.

module mm
  use iso_c_binding
  type, bind (c) :: m
    integer(C_INT) :: i, j
  end type

  integer, parameter :: imax=10, jmax=5
end module

program testit
  use iso_c_binding
  use mm
  implicit none

  type(m) :: aa(imax,jmax)
  integer :: i, j
  do j = 1, jmax
    do i = 1, imax
      aa(i,j)%i = i
      aa(i,j)%j = j
    end do
  end do

  call testc (aa)
  call testf (aa)

contains

  ! C binding version

  subroutine checkc (a, b) bind (c)
    use iso_c_binding
    use mm
    type(m) :: a(..), b(..)

    if (rank (a) .ne. 2) stop 101
    if (rank (b) .ne. 2) stop 102
    if (size (a,1) .ne. imax) stop 103
    if (size (a,2) .ne. jmax) stop 104
    if (size (b,1) .ne. jmax) stop 105
    if (size (b,2) .ne. imax) stop 106

  end subroutine

  ! Fortran binding version
  subroutine checkf (a, b)
    use iso_c_binding
    use mm
    type(m) :: a(..), b(..)

    if (rank (a) .ne. 2) stop 201
    if (rank (b) .ne. 2) stop 202
    if (size (a,1) .ne. imax) stop 203
    if (size (a,2) .ne. jmax) stop 204
    if (size (b,1) .ne. jmax) stop 205
    if (size (b,2) .ne. imax) stop 206

  end subroutine

  ! C binding version
  subroutine testc (a) bind (c)
    use iso_c_binding
    use mm
    type(m) :: a(..)
    type(m) :: b(jmax, imax)

    if (rank (a) .ne. 2) stop 301
    if (size (a,1) .ne. imax) stop 302
    if (size (a,2) .ne. jmax) stop 303

    ! Call both the C and Fortran binding check functions
    call checkc (a, b)
    call checkf (a, b)
  end subroutine

  ! Fortran binding version
  subroutine testf (a)
    use iso_c_binding
    use mm
    type(m) :: a(..)
    type(m) :: b(jmax, imax)

    if (rank (a) .ne. 2) stop 401
    if (size (a,1) .ne. imax) stop 402
    if (size (a,2) .ne. jmax) stop 403

    ! Call both the C and Fortran binding check functions
    call checkc (a, b)
    call checkf (a, b)
  end subroutine

end program