3 ! Test various exponentations
4 ! initially designed for patch to PR31120
7 call run_me (1.0, 1, (1.0,0.0))
8 call run_me (-1.1, -1, (0.0,-1.0))
9 call run_me (42.0, 12, (1.0,7.0))
12 ! This subroutine is for runtime tests
13 subroutine run_me(a
, i
, z
)
17 integer, intent(in
) :: i
18 complex, intent(in
) :: z
20 call check_equal_i (i
**0, 1)
21 call check_equal_i (i
**1, i
)
22 call check_equal_i (i
**2, i
*i
)
23 call check_equal_i (i
**3, i
*(i
**2))
25 ! i has default integer kind.
26 call check_equal_i (int(i
**0_8,kind
=kind(i
)), 1)
27 call check_equal_i (int(i
**1_8,kind
=kind(i
)), i
)
28 call check_equal_i (int(i
**2_8,kind
=kind(i
)), i
*i
)
29 call check_equal_i (int(i
**3_8,kind
=kind(i
)), i
*i
*i
)
31 call check_equal_r (a
**0.0, 1.0)
32 call check_equal_r (a
**1.0, a
)
33 call check_equal_r (a
**2.0, a
*a
)
34 call check_equal_r (a
**3.0, a
*(a
**2))
35 call check_equal_r (a
**(-1.0), 1/a
)
36 call check_equal_r (a
**(-2.0), (1/a
)*(1/a
))
38 call check_equal_r (a
**0, 1.0)
39 call check_equal_r (a
**1, a
)
40 call check_equal_r (a
**2, a
*a
)
41 call check_equal_r (a
**3, a
*(a
**2))
42 call check_equal_r (a
**(-1), 1/a
)
43 call check_equal_r (a
**(-2), (1/a
)*(1/a
))
45 call check_equal_r (a
**0_8, 1.0)
46 call check_equal_r (a
**1_8, a
)
47 call check_equal_r (a
**2_8, a
*a
)
48 call check_equal_r (a
**3_8, a
*(a
**2))
49 call check_equal_r (a
**(-1_8), 1/a
)
50 call check_equal_r (a
**(-2_8), (1/a
)*(1/a
))
52 call check_equal_c (z
**0.0, (1.0,0.0))
53 call check_equal_c (z
**1.0, z
)
54 call check_equal_c (z
**2.0, z
*z
)
55 call check_equal_c (z
**3.0, z
*(z
**2))
56 call check_equal_c (z
**(-1.0), 1/z
)
57 call check_equal_c (z
**(-2.0), (1/z
)*(1/z
))
59 call check_equal_c (z
**(0.0,0.0), (1.0,0.0))
60 call check_equal_c (z
**(1.0,0.0), z
)
61 call check_equal_c (z
**(2.0,0.0), z
*z
)
62 call check_equal_c (z
**(3.0,0.0), z
*(z
**2))
63 call check_equal_c (z
**(-1.0,0.0), 1/z
)
64 call check_equal_c (z
**(-2.0,0.0), (1/z
)*(1/z
))
66 call check_equal_c (z
**0, (1.0,0.0))
67 call check_equal_c (z
**1, z
)
68 call check_equal_c (z
**2, z
*z
)
69 call check_equal_c (z
**3, z
*(z
**2))
70 call check_equal_c (z
**(-1), 1/z
)
71 call check_equal_c (z
**(-2), (1/z
)*(1/z
))
73 call check_equal_c (z
**0_8, (1.0,0.0))
74 call check_equal_c (z
**1_8, z
)
75 call check_equal_c (z
**2_8, z
*z
)
76 call check_equal_c (z
**3_8, z
*(z
**2))
77 call check_equal_c (z
**(-1_8), 1/z
)
78 call check_equal_c (z
**(-2_8), (1/z
)*(1/z
))
83 subroutine check_equal_r (a
, b
)
84 real, intent(in
) :: a
, b
85 if (abs(a
- b
) > 1.e
-5 * abs(b
)) call abort
86 end subroutine check_equal_r
88 subroutine check_equal_c (a
, b
)
89 complex, intent(in
) :: a
, b
90 if (abs(a
- b
) > 1.e
-5 * abs(b
)) call abort
91 end subroutine check_equal_c
93 subroutine check_equal_i (a
, b
)
94 integer, intent(in
) :: a
, b
95 if (a
/= b
) call abort
96 end subroutine check_equal_i
100 ! subroutine foo is used for compilation test only
104 real, intent(in
) :: a
113 call gee_i(i
**(-1_1))
114 call gee_i(i
**(-2_1))
115 call gee_i(i
**(-3_1))
116 call gee_i(i
**huge(0_1))
117 call gee_i(i
**(-huge(0_1)))
118 call gee_i(i
**(-huge(0_1)-1_1))
124 call gee_i(i
**(-1_2))
125 call gee_i(i
**(-2_2))
126 call gee_i(i
**(-3_2))
127 call gee_i(i
**huge(0_2))
128 call gee_i(i
**(-huge(0_2)))
129 call gee_i(i
**(-huge(0_2)-1_2))
135 call gee_i(i
**(-1_4))
136 call gee_i(i
**(-2_4))
137 call gee_i(i
**(-3_4))
138 call gee_i(i
**huge(0_4))
139 call gee_i(i
**(-huge(0_4)))
140 call gee_i(i
**(-huge(0_4)-1_4))
142 call gee_i(i
**0_8) ! { dg-warning "Type mismatch in argument" }
143 call gee_i(i
**1_8) ! { dg-warning "Type mismatch in argument" }
144 call gee_i(i
**2_8) ! { dg-warning "Type mismatch in argument" }
145 call gee_i(i
**3_8) ! { dg-warning "Type mismatch in argument" }
146 call gee_i(i
**(-1_8)) ! { dg-warning "Type mismatch in argument" }
147 call gee_i(i
**(-2_8)) ! { dg-warning "Type mismatch in argument" }
148 call gee_i(i
**(-3_8)) ! { dg-warning "Type mismatch in argument" }
149 call gee_i(i
**huge(0_8)) ! { dg-warning "Type mismatch in argument" }
150 call gee_i(i
**(-huge(0_8))) ! { dg-warning "Type mismatch in argument" }
151 call gee_i(i
**(-huge(0_8)-1_8)) ! { dg-warning "Type mismatch in argument" }
158 call gee_r(a
**(-1_1))
159 call gee_r(a
**(-2_1))
160 call gee_r(a
**(-3_1))
161 call gee_r(a
**huge(0_1))
162 call gee_r(a
**(-huge(0_1)))
163 call gee_r(a
**(-huge(0_1)-1_1))
169 call gee_r(a
**(-1_2))
170 call gee_r(a
**(-2_2))
171 call gee_r(a
**(-3_2))
172 call gee_r(a
**huge(0_2))
173 call gee_r(a
**(-huge(0_2)))
174 call gee_r(a
**(-huge(0_2)-1_2))
180 call gee_r(a
**(-1_4))
181 call gee_r(a
**(-2_4))
182 call gee_r(a
**(-3_4))
183 call gee_r(a
**huge(0_4))
184 call gee_r(a
**(-huge(0_4)))
185 call gee_r(a
**(-huge(0_4)-1_4))
191 call gee_r(a
**(-1_8))
192 call gee_r(a
**(-2_8))
193 call gee_r(a
**(-3_8))
194 call gee_r(a
**huge(0_8))
195 call gee_r(a
**(-huge(0_8)))
196 call gee_r(a
**(-huge(0_8)-1_8))
203 call gee_z(z
**(-1_1))
204 call gee_z(z
**(-2_1))
205 call gee_z(z
**(-3_1))
206 call gee_z(z
**huge(0_1))
207 call gee_z(z
**(-huge(0_1)))
208 call gee_z(z
**(-huge(0_1)-1_1))
214 call gee_z(z
**(-1_2))
215 call gee_z(z
**(-2_2))
216 call gee_z(z
**(-3_2))
217 call gee_z(z
**huge(0_2))
218 call gee_z(z
**(-huge(0_2)))
219 call gee_z(z
**(-huge(0_2)-1_2))
225 call gee_z(z
**(-1_4))
226 call gee_z(z
**(-2_4))
227 call gee_z(z
**(-3_4))
228 call gee_z(z
**huge(0_4))
229 call gee_z(z
**(-huge(0_4)))
230 call gee_z(z
**(-huge(0_4)-1_4))
236 call gee_z(z
**(-1_8))
237 call gee_z(z
**(-2_8))
238 call gee_z(z
**(-3_8))
239 call gee_z(z
**huge(0_8))
240 call gee_z(z
**(-huge(0_8)))
241 call gee_z(z
**(-huge(0_8)-1_8))
