view liboctave/external/amos/cs1s2.f @ 23434:f4d4d83f15c5

maint: rename cruft/ directory to external/ * liboctave/external: Renamed from liboctave/cruft. * * configure.ac: Rename XTRA_CRUFT_SH_LDFLAGS to XTRA_EXTERNAL_SH_LDFLAGS. Rename CRUFT_DLL_DEFS to EXTERNAL_DLL_DEFS. * install.txi: Update documentation to refer to liboctave/external. * HACKING: Update explanation of directory tree. * liboctave/module.mk: Update build system to include liboctave/external * liboctave/numeric/module.mk: Update CPPFLAGS to find Faddeeva in external/ directory. * lo-blas-proto.h, lo-lapack-proto.h: Update comments which referred to cruft directory.
author Rik <rik@octave.org>
date Mon, 24 Apr 2017 21:03:38 -0700
parents liboctave/cruft/amos/cs1s2.f@648dabbb4c6b
children
line wrap: on
line source

      SUBROUTINE CS1S2(ZR, S1, S2, NZ, ASCLE, ALIM, IUF)
C***BEGIN PROLOGUE  CS1S2
C***REFER TO  CBESK,CAIRY
C
C     CS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE
C     ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON-
C     TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION.
C     ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF
C     MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER
C     OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE
C     PRECISION ABOVE THE UNDERFLOW LIMIT.
C
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  CS1S2
      COMPLEX CZERO, C1, S1, S1D, S2, ZR
      REAL AA, ALIM, ALN, ASCLE, AS1, AS2, XX
      INTEGER IUF, NZ
      DATA CZERO / (0.0E0,0.0E0) /
      NZ = 0
      AS1 = CABS(S1)
      AS2 = CABS(S2)
      AA = REAL(S1)
      ALN = AIMAG(S1)
      IF (AA.EQ.0.0E0 .AND. ALN.EQ.0.0E0) GO TO 10
      IF (AS1.EQ.0.0E0) GO TO 10
      XX = REAL(ZR)
      ALN = -XX - XX + ALOG(AS1)
      S1D = S1
      S1 = CZERO
      AS1 = 0.0E0
      IF (ALN.LT.(-ALIM)) GO TO 10
      C1 = CLOG(S1D) - ZR - ZR
      S1 = CEXP(C1)
      AS1 = CABS(S1)
      IUF = IUF + 1
   10 CONTINUE
      AA = AMAX1(AS1,AS2)
      IF (AA.GT.ASCLE) RETURN
      S1 = CZERO
      S2 = CZERO
      NZ = 1
      IUF = 0
      RETURN
      END