diff libcruft/amos/casyi.f @ 7789:82be108cc558

First attempt at single precision tyeps * * * corrections to qrupdate single precision routines * * * prefer demotion to single over promotion to double * * * Add single precision support to log2 function * * * Trivial PROJECT file update * * * Cache optimized hermitian/transpose methods * * * Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author David Bateman <dbateman@free.fr>
date Sun, 27 Apr 2008 22:34:17 +0200
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/libcruft/amos/casyi.f	Sun Apr 27 22:34:17 2008 +0200
@@ -0,0 +1,126 @@
+      SUBROUTINE CASYI(Z, FNU, KODE, N, Y, NZ, RL, TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  CASYI
+C***REFER TO  CBESI,CBESK
+C
+C     CASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
+C     MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE
+C     REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN.
+C     NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1.
+C
+C***ROUTINES CALLED  R1MACH
+C***END PROLOGUE  CASYI
+      COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, RZ, S2,
+     * Y, Z
+      REAL AA, ACZ, AEZ, AK, ALIM, ARG, ARM, ATOL, AZ, BB, BK, DFNU,
+     * DNU2, ELIM, FDN, FNU, PI, RL, RTPI, RTR1, S, SGN, SQK, TOL, X,
+     * YY, R1MACH
+      INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ
+      DIMENSION Y(N)
+      DATA PI, RTPI  /3.14159265358979324E0 , 0.159154943091895336E0 /
+      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
+C
+      NZ = 0
+      AZ = CABS(Z)
+      X = REAL(Z)
+      ARM = 1.0E+3*R1MACH(1)
+      RTR1 = SQRT(ARM)
+      IL = MIN0(2,N)
+      DFNU = FNU + FLOAT(N-IL)
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST
+C-----------------------------------------------------------------------
+      AK1 = CMPLX(RTPI,0.0E0)/Z
+      AK1 = CSQRT(AK1)
+      CZ = Z
+      IF (KODE.EQ.2) CZ = Z - CMPLX(X,0.0E0)
+      ACZ = REAL(CZ)
+      IF (ABS(ACZ).GT.ELIM) GO TO 80
+      DNU2 = DFNU + DFNU
+      KODED = 1
+      IF ((ABS(ACZ).GT.ALIM) .AND. (N.GT.2)) GO TO 10
+      KODED = 0
+      AK1 = AK1*CEXP(CZ)
+   10 CONTINUE
+      FDN = 0.0E0
+      IF (DNU2.GT.RTR1) FDN = DNU2*DNU2
+      EZ = Z*CMPLX(8.0E0,0.0E0)
+C-----------------------------------------------------------------------
+C     WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE
+C     FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE
+C     EXPANSION FOR THE IMAGINARY PART.
+C-----------------------------------------------------------------------
+      AEZ = 8.0E0*AZ
+      S = TOL/AEZ
+      JL = INT(RL+RL) + 2
+      YY = AIMAG(Z)
+      P1 = CZERO
+      IF (YY.EQ.0.0E0) GO TO 20
+C-----------------------------------------------------------------------
+C     CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF
+C     SIGNIFICANCE WHEN FNU OR N IS LARGE
+C-----------------------------------------------------------------------
+      INU = INT(FNU)
+      ARG = (FNU-FLOAT(INU))*PI
+      INU = INU + N - IL
+      AK = -SIN(ARG)
+      BK = COS(ARG)
+      IF (YY.LT.0.0E0) BK = -BK
+      P1 = CMPLX(AK,BK)
+      IF (MOD(INU,2).EQ.1) P1 = -P1
+   20 CONTINUE
+      DO 50 K=1,IL
+        SQK = FDN - 1.0E0
+        ATOL = S*ABS(SQK)
+        SGN = 1.0E0
+        CS1 = CONE
+        CS2 = CONE
+        CK = CONE
+        AK = 0.0E0
+        AA = 1.0E0
+        BB = AEZ
+        DK = EZ
+        DO 30 J=1,JL
+          CK = CK*CMPLX(SQK,0.0E0)/DK
+          CS2 = CS2 + CK
+          SGN = -SGN
+          CS1 = CS1 + CK*CMPLX(SGN,0.0E0)
+          DK = DK + EZ
+          AA = AA*ABS(SQK)/BB
+          BB = BB + AEZ
+          AK = AK + 8.0E0
+          SQK = SQK - AK
+          IF (AA.LE.ATOL) GO TO 40
+   30   CONTINUE
+        GO TO 90
+   40   CONTINUE
+        S2 = CS1
+        IF (X+X.LT.ELIM) S2 = S2 + P1*CS2*CEXP(-Z-Z)
+        FDN = FDN + 8.0E0*DFNU + 4.0E0
+        P1 = -P1
+        M = N - IL + K
+        Y(M) = S2*AK1
+   50 CONTINUE
+      IF (N.LE.2) RETURN
+      NN = N
+      K = NN - 2
+      AK = FLOAT(K)
+      RZ = (CONE+CONE)/Z
+      IB = 3
+      DO 60 I=IB,NN
+        Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)
+        AK = AK - 1.0E0
+        K = K - 1
+   60 CONTINUE
+      IF (KODED.EQ.0) RETURN
+      CK = CEXP(CZ)
+      DO 70 I=1,NN
+        Y(I) = Y(I)*CK
+   70 CONTINUE
+      RETURN
+   80 CONTINUE
+      NZ = -1
+      RETURN
+   90 CONTINUE
+      NZ=-2
+      RETURN
+      END