1** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
2**
3** Licensed under the Apache License, Version 2.0 (the "License");
4** you may not use this file except in compliance with the License.
5** You may obtain a copy of the License at
6**
7**     http://www.apache.org/licenses/LICENSE-2.0
8**
9** Unless required by applicable law or agreed to in writing, software
10** distributed under the License is distributed on an "AS IS" BASIS,
11** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12** See the License for the specific language governing permissions and
13** limitations under the License.
14
15*   Exponentiation operator (**) - exponentiation of integer,
16*   real, d.p., or complex values to an integer power,
17*   including constant folding.
18
19	implicit double precision (d), complex(c)
20	parameter(n = 34)
21	integer rslts(n), expect(n), iexpect(12)
22	real rrslts(13:18), rexpect(13:18)
23	double precision drslts(4), dexpect(4)
24	complex crslts(4), cexpect(4)
25
26	equivalence (expect, iexpect), (expect(13), rexpect),
27     +              (expect(19), dexpect), (expect(27), cexpect)
28	equivalence (rslts(13), rrslts(13)), (rslts(19), drslts),
29     +              (rslts(27), crslts)
30
31	parameter(ip1 = 138 ** 1, ip2 = -4 ** 2, ip3 = 5**0,
32     +            ip4 = -5**3, ip5 = 1 ** 20, ip6 = 1**(-3),
33     +            ip7 = 2 ** (-1), ip8=5**(-2), ip9=2**3**2  )
34
35	parameter(xp1 = 2.0 ** 2, xp2 = 4.0 ** (-1), xp3 = -3.0 ** 3,
36     +            xp4 = 2.3 ** 1, xp5 = 2.0 ** (-2) )
37
38	parameter(dp1 = 2.0D0 ** 3, dp2 = 2.3d45**0, dp3=(-2.0d0)**(-2))
39
40	parameter(cp1 = (2.0, 0.0) ** 3, cp2 = (2.3, 2.3) ** 1,
41     +            cp3 = (2.3, 2.3) ** 0, cp4 = (1.0, 1.0) ** 2  )
42
43c ----------- tests 1 - 12:    integer ** integer
44
45	data iexpect / ip1, ip2, ip2, ip3, ip4, ip5,
46     +                 ip6, ip7, ip8, ip9, ip9, 125  /
47
48	data i138, i4, i2, i3, i5, i20, in3, i1, in2, in1 /
49     +        138,  4,  2,  3,  5,  20,  -3,  1,  -2, -1  /
50
51	rslts(1) = i138 ** i1
52	rslts(2) = - (i4 ** i2)
53	rslts(3) = - i4 ** i2
54	rslts(4) = i5 ** (i2 / i3)
55	rslts(5) = - i5 ** (i2 + i1)
56	rslts(6) = i1 ** i20
57	rslts(7) = i1 ** (in3)
58	rslts(8) = (i1 * i2) ** (-i1)
59	rslts(9) = 5 ** (in2)
60	rslts(10) = (-in2) ** if(3) ** 2
61	rslts(11) = i2 ** (i3 ** i2)
62	rslts(12) = if(5) ** 3
63
64c ------------ tests 13 - 18:   real ** integer
65
66	data rexpect / xp1, xp2, xp3, xp4, xp5, 9.0 /
67
68	data x3, x23, x2 / 3.0, 2.3, 2.0 /
69
70	rrslts(13) = 4.0
71	rrslts(14) = 4.0 ** in1
72	rrslts(15) = -x3**3
73	rrslts(16) = x23 ** (i2 - 1)
74	rrslts(17) = x2 ** (- i2)
75	rrslts(18) = xf( -x3 ) ** 2
76
77c ------------- tests 19 - 26:   double ** integer
78
79	data dexpect / dp1, dp2, dp3, 4.0D0  /
80
81	data d2 / 2.0d0 /
82
83	drslts(1) = d2 ** i3
84	drslts(2) = 2.3D45 ** (i2 - i1 - i1)
85	drslts(3) = (-d2) ** (-i2)
86	drslts(4) = d2 ** 2
87
88c -------------- tests 27 - 34:  complex ** integer
89
90	data cexpect / cp1, cp2, cp3, cp4 /
91
92	data         c2,        c23,       cn1_1  /
93     +       (2.0, 0.0), (2.3, 2.3), (-1.0, 1.0)  /
94
95        crslts(1) = c2 ** i3
96        crslts(2) = (2.3, 2.3) ** (i2 - i1)
97        crslts(3) = c23 ** 0
98        crslts(4) = (c2 + cn1_1) ** 2
99
100c --------------- check results:
101
102	call check(rslts, expect, n)
103	end
104
105
106	integer function if(i)
107	common /comif/ ii
108	data ii /0/
109	if (ii .gt. 1)  stop "'if' called too often"
110        ii = ii + 1
111	if =  i
112	end
113
114	real function xf(x)
115	common /comxf/ ii
116	data ii /0/
117	if (ii .gt. 1)  stop "'xf' called too often"
118        ii = ii + 1
119	xf = x
120	end
121