gcc/testsuite/g77.f-torture/execute/select.f

   1 C   integer byte case with integer byte parameters as case(s)
   2         subroutine ib
   3         integer *1 a /1/
   4         integer *1  one,two,three
   5         parameter (one=1,two=2,three=3)
   6         select case (a)
   7         case (one)
   8         case (two)
   9            call abort
  10         case (three)
  11            call abort
  12         case default
  13            call abort
  14         end select
  15         print*,'normal ib'
  16         end
  17 C   integer halfword case with integer halfword parameters
  18         subroutine ih
  19         integer *2 a /1/
  20         integer *2  one,two,three
  21         parameter (one=1,two=2,three=3)
  22         select case (a)
  23         case (one)
  24         case (two)
  25            call abort
  26         case (three)
  27            call abort
  28         case default
  29            call abort
  30         end select
  31         print*,'normal ih'
  32         end
  33 C   integer case with integer parameters
  34         subroutine iw
  35         integer *4 a /1/
  36         integer *4  one,two,three
  37         parameter (one=1,two=2,three=3)
  38         select case (a)
  39         case (one)
  40         case (two)
  41            call abort
  42         case (three)
  43            call abort
  44         case default
  45            call abort
  46         end select
  47         print*,'normal iw'
  48         end
  49 C   integer double case with integer double parameters
  50         subroutine id
  51         integer *8 a /1/
  52         integer *8  one,two,three
  53         parameter (one=1,two=2,three=3)
  54         select case (a)
  55         case (one)
  56         case (two)
  57            call abort
  58         case (three)
  59            call abort
  60         case default
  61            call abort
  62         end select
  63         print*,'normal id'
  64         end
  65 C   integer byte select with integer case
  66        subroutine ib_mixed
  67        integer*1 s /1/
  68        select case (s)
  69        case (1)
  70        case (2)
  71          call abort
  72        end select
  73        print*,'ib ok'
  74        end
  75 C   integer halfword with integer case
  76        subroutine ih_mixed
  77        integer*2 s /1/
  78        select case (s)
  79        case (1)
  80        case default
  81          call abort
  82        end select
  83        print*,'ih ok'
  84        end
  85 C   integer word with integer case
  86        subroutine iw_mixed
  87        integer s /5/
  88        select case (s)
  89        case (1)
  90           call abort
  91        case (2)
  92           call abort
  93        case (3)
  94           call abort
  95        case (4)
  96           call abort
  97        case (5)
  98 C
  99        case (6)
 100            call abort
 101        case default
 102            call abort
 103        end select
 104        print*,'iw ok'
 105        end
 106 C   integer doubleword with integer case
 107        subroutine id_mixed
 108        integer *8 s /1024/
 109        select case (s)
 110        case (1)
 111            call abort
 112        case (1023)
 113            call abort
 114        case (1025)
 115            call abort
 116        case (1024)
 117 C
 118        end select
 119        print*,'i8 ok'
 120        end
 121        subroutine l1_mixed
 122        logical*1 s /.TRUE./
 123        select case (s)
 124        case (.TRUE.)
 125        case (.FALSE.)
 126           call abort
 127        end select
 128        print*,'l1 ok'
 129        end
 130        subroutine l2_mixed
 131        logical*2 s /.FALSE./
 132        select case (s)
 133        case (.TRUE.)
 134            call abort
 135        case (.FALSE.)
 136        end select
 137        print*,'lh ok'
 138        end
 139        subroutine l4_mixed
 140        logical*4 s /.TRUE./
 141        select case (s)
 142        case (.FALSE.)
 143          call abort
 144        case (.TRUE.)
 145        end select
 146        print*,'lw ok'
 147        end
 148        subroutine l8_mixed
 149        logical*8 s /.TRUE./
 150        select case (s)
 151        case (.TRUE.)
 152        case (.FALSE.)
 153           call abort
 154        end select
 155        print*,'ld ok'
 156        end
 157 C   main
 158 C -- regression cases
 159         call ib
 160         call ih
 161         call iw
 162         call id
 163 C -- new functionality
 164         call ib_mixed
 165         call ih_mixed
 166         call iw_mixed
 167         call id_mixed
 168         end
 169
 170
 171
 172
 173