gcc/testsuite/gfortran.dg/substr_4.f

   1 ! { dg-do run }
   2       subroutine test_lower
   3       implicit none
   4       character(3), dimension(3) :: zsymel,zsymelr
   5       common /xx/ zsymel, zsymelr
   6       integer :: znsymelr
   7       zsymel = (/ 'X', 'Y', ' ' /)
   8       zsymelr= (/ 'X', 'Y', ' ' /)
   9       znsymelr=2
  10       call check_zsymel(zsymel,zsymelr,znsymelr)
  11
  12       contains
  13
  14       subroutine check_zsymel(zsymel,zsymelr,znsymelr)
  15         implicit none
  16         integer znsymelr, isym
  17         character(*) zsymel(*),zsymelr(*)
  18         character(len=80) buf
  19         zsymel(3)(lenstr(zsymel(3))+1:)='X'
  20         write (buf,10) (trim(zsymelr(isym)),isym=1,znsymelr)
  21 10      format(3(a,:,','))
  22         if (trim(buf) /= 'X,Y') STOP 1
  23       end subroutine check_zsymel
  24
  25       function lenstr(s)
  26         character(len=*),intent(in) :: s
  27         integer :: lenstr
  28         if (len_trim(s) /= 0) STOP 2
  29         lenstr = len_trim(s)
  30       end function lenstr
  31
  32       end subroutine test_lower
  33
  34       subroutine test_upper
  35       implicit none
  36       character(3), dimension(3) :: zsymel,zsymelr
  37       common /xx/ zsymel, zsymelr
  38       integer :: znsymelr
  39       zsymel = (/ 'X', 'Y', ' ' /)
  40       zsymelr= (/ 'X', 'Y', ' ' /)
  41       znsymelr=2
  42       call check_zsymel(zsymel,zsymelr,znsymelr)
  43
  44       contains
  45
  46       subroutine check_zsymel(zsymel,zsymelr,znsymelr)
  47         implicit none
  48         integer znsymelr, isym
  49         character(*) zsymel(*),zsymelr(*)
  50         character(len=80) buf
  51         zsymel(3)(:lenstr(zsymel(3))+1)='X'
  52         write (buf,20) (trim(zsymelr(isym)),isym=1,znsymelr)
  53 20      format(3(a,:,','))
  54         if (trim(buf) /= 'X,Y') STOP 3
  55       end subroutine check_zsymel
  56
  57       function lenstr(s)
  58         character(len=*),intent(in) :: s
  59         integer :: lenstr
  60         if (len_trim(s) /= 0) STOP 4
  61         lenstr = len_trim(s)
  62       end function lenstr
  63
  64       end subroutine test_upper
  65
  66       program test
  67         call test_lower
  68         call test_upper
  69       end program test