gcc/testsuite/gfortran.dg/pr61335.f90

   1 ! { dg-do run }
   2 ! { dg-require-visibility "" }
   3 ! { dg-additional-options "-fbounds-check" }
   4 MODULE cp_units
   5
   6   INTEGER, PARAMETER :: default_string_length=80, dp=KIND(0.0D0)
   7
   8   LOGICAL, PRIVATE, PARAMETER          :: debug_this_module=.TRUE.
   9   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_units'
  10   INTEGER, SAVE, PRIVATE               :: last_unit_id=0, last_unit_set_id=0
  11
  12   INTEGER, PARAMETER, PUBLIC :: cp_unit_max_kinds=8, cp_unit_basic_desc_length=15,&
  13        cp_unit_desc_length=cp_unit_max_kinds*cp_unit_basic_desc_length, cp_ukind_max=9
  14
  15 CONTAINS
  16
  17   FUNCTION cp_to_string(i) RESULT(res)
  18     INTEGER, INTENT(in)                      :: i
  19     CHARACTER(len=6)                         :: res
  20
  21     INTEGER                                  :: iostat
  22     REAL(KIND=dp)                            :: tmp_r
  23
  24     IF (i>999999 .OR. i<-99999) THEN
  25        tmp_r=i
  26        WRITE (res,fmt='(es6.1)',iostat=iostat) tmp_r
  27     ELSE
  28        WRITE (res,fmt='(i6)',iostat=iostat) i
  29     END IF
  30     IF (iostat/=0) THEN
  31        STOP 7
  32     END IF
  33   END FUNCTION cp_to_string
  34
  35   SUBROUTINE cp_unit_create(string)
  36     CHARACTER(len=*), INTENT(in)             :: string
  37
  38     CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_create', &
  39       routineP = moduleN//':'//routineN
  40
  41     CHARACTER(default_string_length)         :: desc
  42     CHARACTER(LEN=40)                        :: formatstr
  43     INTEGER                                  :: i_high, i_low, i_unit, &
  44                                                 len_string, next_power
  45     INTEGER, DIMENSION(cp_unit_max_kinds)    :: kind_id, power, unit_id
  46     LOGICAL                                  :: failure
  47
  48     failure=.FALSE.
  49     unit_id=0
  50     kind_id=0
  51     power=0
  52     i_low=1
  53     i_high=1
  54     len_string=LEN(string)
  55     i_unit=0
  56     next_power=1
  57     DO WHILE(i_low<len_string)
  58        IF (string(i_low:i_low)/=' ') EXIT
  59        i_low=i_low+1
  60     END DO
  61     i_high=i_low
  62     DO WHILE(i_high<=len_string)
  63        IF ( string(i_high:i_high)==' '.OR.string(i_high:i_high)=='^'.OR.&
  64             string(i_high:i_high)=='*'.OR.string(i_high:i_high)=='/') EXIT
  65        i_high=i_high+1
  66     END DO
  67     DO WHILE(.NOT.failure)
  68        IF (i_high<=i_low.OR.i_low>len_string) EXIT
  69        i_unit=i_unit+1
  70        IF (i_unit>cp_unit_max_kinds) THEN
  71           EXIT
  72        END IF
  73        power(i_unit)=next_power
  74        ! parse op
  75        i_low=i_high
  76        DO WHILE(i_low<=len_string)
  77           IF (string(i_low:i_low)/=' ') EXIT
  78           i_low=i_low+1
  79        END DO
  80        i_high=i_low
  81        DO WHILE(i_high<=len_string)
  82           IF ( string(i_high:i_high)==' '.OR.string(i_high:i_high)=='^'.OR.&
  83                string(i_high:i_high)=='*'.OR.string(i_high:i_high)=='/') EXIT
  84           i_high=i_high+1
  85        END DO
  86        IF (i_high<i_low.OR.i_low>len_string) EXIT
  87
  88        IF (i_high<=len_string) THEN
  89           IF (string(i_low:i_high)=='^') THEN
  90              i_low=i_high+1
  91              DO WHILE(i_low<=len_string)
  92                 IF (string(i_low:i_low)/=' ') EXIT
  93                 i_low=i_low+1
  94              END DO
  95              i_high=i_low
  96              DO WHILE(i_high<=len_string)
  97                 SELECT CASE(string(i_high:i_high))
  98                 CASE('+','-','0','1','2','3','4','5','6','7','8','9')
  99                    i_high=i_high+1
 100                 CASE default
 101                    EXIT
 102                 END SELECT
 103              END DO
 104              IF (i_high<=i_low.OR.i_low>len_string) THEN
 105                 write(6,*) "BUG : XXX"//string//"XXX integer expected"
 106                 STOP 1
 107                 EXIT
 108              END IF
 109           END IF
 110        ENDIF
 111     END DO
 112   END SUBROUTINE cp_unit_create
 113
 114 END MODULE cp_units
 115
 116 USE cp_units
 117 CALL cp_unit_create("fs^-1")
 118 END