gcc/testsuite/gfortran.dg/elemental_optional_args_3.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/50981
   4 ! The program used to dereference a NULL pointer when trying to access
   5 ! a pointer dummy argument to be passed to an elemental subprocedure.
   6 !
   7 ! Original testcase from Andriy Kostyuk <kostyuk@fias.uni-frankfurt.de>
   8
   9 PROGRAM test
  10   IMPLICIT NONE
  11   REAL(KIND=8), DIMENSION(2) :: aa, rr
  12   INTEGER, TARGET  :: c
  13   INTEGER, POINTER :: b
  14
  15   aa(1)=10.
  16   aa(2)=11.
  17
  18   b=>c
  19   b=1
  20
  21   ! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:'
  22
  23   rr=f1(aa,b)
  24   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  25   IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
  26
  27   rr=0
  28   rr=ff(aa,b)
  29   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  30   IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
  31
  32
  33   b => NULL()
  34   ! WRITE(*,*) 'But only f1 works if the optional parameter is absent:'
  35
  36   rr=0
  37   rr=f1(aa, b)
  38   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  39   IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
  40
  41   rr = 0
  42   rr=ff(aa, b)
  43   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  44   IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
  45
  46
  47 CONTAINS
  48
  49     FUNCTION ff(a,b)
  50       IMPLICIT NONE
  51       REAL(KIND=8), INTENT(IN) :: a(:)
  52       REAL(KIND=8), DIMENSION(SIZE(a)) :: ff
  53       INTEGER, INTENT(IN), POINTER :: b
  54       REAL(KIND=8), DIMENSION(2, SIZE(a)) :: ac
  55       ac(1,:)=a
  56       ac(2,:)=a**2
  57       ff=SUM(gg(ac,b), dim=1)
  58     END FUNCTION ff
  59
  60     FUNCTION f1(a,b)
  61       IMPLICIT NONE
  62       REAL(KIND=8), INTENT(IN) :: a(:)
  63       REAL(KIND=8), DIMENSION(SIZE(a)) :: f1
  64       INTEGER, INTENT(IN), POINTER :: b
  65       REAL(KIND=8), DIMENSION(2, SIZE(a)) :: ac
  66       ac(1,:)=a
  67       ac(2,:)=a**2
  68       f1=gg(ac(1,:),b)+gg(ac(2,:),b) ! This is the same as in ff, but without using the elemental feature of gg
  69     END FUNCTION f1
  70
  71     ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b)
  72       IMPLICIT NONE
  73       REAL(KIND=8), INTENT(IN) :: a
  74       INTEGER, INTENT(IN), OPTIONAL :: b
  75       INTEGER ::b1
  76       IF(PRESENT(b)) THEN
  77         b1=b
  78       ELSE
  79         b1=1
  80       ENDIF
  81       gg=a**b1
  82     END FUNCTION gg
  83
  84
  85 END PROGRAM test