gcc/testsuite/gfortran.dg/pr61335.f90

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