1      real             function SCSPXX (X)
2c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
3c ALL RIGHTS RESERVED.
4c Based on Government Sponsored Research NAS7-03001.
5C>> 2001-07-16 SCSPXX Krogh  -1.0 changed to -1.E0.
6C>> 1998-10-29 SCSPXX Krogh  Moved external statement up for mangle.
7c>> 1996-01-08 SCSPXX WV Snyder Original code
8c--S replaces "?": ?CSPXX, ?COSPX, ?SINPX
9
10c COS(PI * X * X / 2) carefully to avoid loss of precision for large X
11
12      real             X
13
14c SCOSPX is used to compute COS(PI * X)
15
16      external R1MACH, SCOSPX, SSINPX
17      real             R1MACH, SCOSPX, SSINPX
18
19c BIGX = 1 / round-off = biggest integer exactly representable by F.P.
20c    If X > BIGX then to the working precision x**2 is an integer (which
21c    we assume to be a multiple of four), so cos(pi/2 * x**2) = 1.
22c N = [X], and later [K F]
23c F = X - N = fractional part of X
24c K = [ N / 2 ]
25c J = N mod 2
26c M = [K F]
27c G = K F - M = fractional part of K F
28
29      integer J, K, N
30      real             BIGX, F, G
31      save BIGX
32      data BIGX /-1.0e0/
33
34      if (bigx .lt. 0.0e0) bigx = 1.0e0 / r1mach(4)
35      f = abs(x)
36      if (f .gt. bigx) then
37c       Assume x is an even integer.
38        scspxx = 1.0e0
39        return
40      endif
41      n = f
42      f = f - n
43      k = n / 2
44      j = mod(n,2)
45      g = k * f
46      n = g
47      g = g - n
48      if (j .eq. 0) then
49        scspxx = scospx(0.5e0*f*f + g + g)
50      else
51        scspxx = -ssinpx(0.5e0*f*f + f + g + g)
52      endif
53      return
54      end
55