gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90

   1 ! { dg-do run }
   2
   3 MODULE distribution_types
   4   ABSTRACT INTERFACE
   5      FUNCTION dist_map_blk_to_proc_func ( row, col, nrow_tot, ncol_tot, proc_grid ) RESULT( reslt )
   6        INTEGER, INTENT( IN ) :: row, col, nrow_tot, ncol_tot
   7        INTEGER, DIMENSION( : ), INTENT( IN ) :: proc_grid
   8        INTEGER, DIMENSION( : ), ALLOCATABLE :: reslt
   9      END FUNCTION dist_map_blk_to_proc_func
  10   END INTERFACE
  11   TYPE, PUBLIC :: dist_type
  12      INTEGER, DIMENSION( : ), ALLOCATABLE :: task_coords
  13      PROCEDURE( dist_map_blk_to_proc_func ), NOPASS, POINTER :: map_blk_to_proc => NULL( )
  14   END TYPE dist_type
  15 END MODULE distribution_types
  16
  17 MODULE sparse_matrix_types
  18   USE distribution_types,  ONLY : dist_type
  19   TYPE, PUBLIC :: sm_type
  20      TYPE( dist_type ) :: dist
  21   END TYPE sm_type
  22 END MODULE sparse_matrix_types
  23
  24 PROGRAM comp_proc_ptr_test
  25   USE sparse_matrix_types,      ONLY : sm_type
  26
  27  call  sm_multiply_a ()
  28 CONTAINS
  29   SUBROUTINE sm_multiply_a (  )
  30     INTEGER :: n_push_tot, istat
  31     TYPE( sm_type ), DIMENSION( : ), ALLOCATABLE :: matrices_a, matrices_b
  32     n_push_tot =2
  33     ALLOCATE( matrices_a( n_push_tot + 1 ), matrices_b( n_push_tot + 1), STAT=istat )
  34     if (istat /= 0) call abort()
  35     if (.not. allocated(matrices_a)) call abort()
  36     if (.not. allocated(matrices_b)) call abort()
  37     if (associated(matrices_a(1)%dist%map_blk_to_proc)) call abort()
  38   END SUBROUTINE sm_multiply_a
  39 END PROGRAM comp_proc_ptr_test
  40