gcc/testsuite/gfortran.dg/pointer_array_5.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR55763 comment 9 as part of the overall fix for PR34640.
   4 !
   5 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
   6 !
   7   program change_field_type
   8     use, intrinsic :: iso_c_binding
   9     implicit none
  10     REAL(kind=c_float), POINTER :: vector_comp(:)
  11     TYPE, BIND(C) :: scalar_vector
  12        REAL(kind=c_float) :: scalar
  13        REAL(kind=c_float) :: vec(3)
  14     END TYPE
  15     TYPE, BIND(C) :: scalar_vector_matrix
  16        REAL(kind=c_float) :: scalar
  17        REAL(kind=c_float) :: vec(3)
  18        REAL(kind=c_float) :: mat(3,3)
  19     END TYPE
  20     CLASS(*), ALLOCATABLE, TARGET :: one_d_field(:)
  21     real, pointer :: v1(:)
  22
  23     allocate(one_d_field(3), &
  24              source = (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), &
  25                          scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), &
  26                          scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) )  /) )
  27
  28     call extract_vec(one_d_field, 1, 2)
  29     if (any (abs (vector_comp - [0.0,0.2,0.4]) .gt. 1e-4)) STOP 1
  30     deallocate(one_d_field)   ! v1 becomes undefined
  31
  32     allocate(one_d_field(1), &
  33          source = (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), &
  34          reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), &
  35                  (/3, 3/) ) ) /) )
  36
  37     call extract_vec(one_d_field, 2, 1)
  38     if (abs (vector_comp(1) + 1.0) > 1e-4) STOP 2
  39     call extract_vec(one_d_field, 2, 3)
  40     if (abs (vector_comp(1) - 1.0) > 1e-4) STOP 3
  41     deallocate(one_d_field)   ! v1 becomes undefined
  42   contains
  43     subroutine extract_vec(field, tag, ic)
  44         use, intrinsic :: iso_c_binding
  45         CLASS(*), TARGET :: field(:)
  46         INTEGER(kind=c_int), value :: tag, ic
  47
  48         type(scalar_vector), pointer :: sv(:)
  49         type(scalar_vector_matrix), pointer :: svm(:)
  50
  51         select type (field)
  52         type is (real(c_float))
  53           vector_comp => field
  54         class default
  55           select case (tag)
  56           case (1)
  57              sv => field
  58              vector_comp => sv(:)%vec(ic)
  59           case (2)
  60              svm => field
  61              vector_comp => svm(:)%vec(ic)
  62           end select
  63         end select
  64     end subroutine
  65   end program