gcc/testsuite/gfortran.dg/elemental_optional_args_4.f90

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