C main.f
      CALL FBILD
      STOP
      END
C fbild.f
      SUBROUTINE FBILD
C23456789012345678901234567890123456789012345678901234567890123456789012
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C BERECHNE WERTE DER FELDER BEI Z=Z(I) AUS DEN D(I,N) UND C(I,N)
C TEIL DER DIPLOMARBEIT VON WARNER BRUNS
C BEGINN AM 3.4.'92
C
C VERSION VOM 6.6.'92
C
      INTEGER LDA,GM,MF
      PARAMETER (LDA=100,GM=800,MF=10,RNULL= 0.,ITSD= 1 000)
C
C LDA: ANZAHL MODEN
C GM+1: ANZAHL BEREICHE
C MF: ANZAHL FREQUENZPUNKTE
C
      DOUBLE PRECISION BETA
      COMMON /VIEL2/ BETA,K,RQ
      COMMON /CIGN/ IGN
      COMMON /CISRC/ ISC
      COMMON /CITM/ ITM,ITE
      DOUBLEPRECISION OMEGA,RA,RB,R(0:GM),Z(0:GM),DZ(0:GM),
     1 RDZ,DR,ZARR(10 000),RARR(10 000),WORK(10 000),
     2 B,KR0,KNA,KNE,NULLF,CT,BREITE,DICHTE,WINKEL,
     3 XMAX,YMAX,XTEXT,YTEXT,WTEXT,DYTEXT,HTEXT,
     4 SL1,SL2,ZWL,DYT,JM(LDA),JMS(LDA)
      COMMON /CDRAW/ IRA,IZA,RARR,ZARR
      DIMENSION WERTE(5 000 000)
      DIMENSION RLEG1(LDA*ITSD),RLEG2(LDA*ITSD),
     1 RLEG3(LDA*ITSD),RLEG4(LDA*ITSD)
      CHARACTER*20 STR20
      CHARACTER*40 STR40
      CHARACTER*80 STR
      INTEGER ISTEP,MATRIX,IFREQ,IF,IDUM,IND(10000),NBAR
      DOUBLECOMPLEX PHASE,ZDUM
     !! DOUBLECOMPLEX D0(MF)
      DOUBLECOMPLEX
     1 LAMBDA(LDA,2,0:GM,MF),ATM(2,0:GM,MF),BTM(2,0:GM,MF),
     2 C(LDA,2,0:GM,MF),D(LDA,2,0:GM,MF)
    !!  DOUBLEPRECISION G0(MF),LAMBD0(MF)
      INTEGER PSTEP
      DOUBLEPRECISION ZW1,ZW2,RFAKT,ZFAKT,SCAL,FAKTL,FAKTR
      DOUBLEPRECISION Q,K
      DOUBLECOMPLEX EPS(0:GM)
      COMMON /EPS/EPS
      DOUBLEPRECISION C0,MUE,EPS0,PI
      DIMENSION IBITMP(1 000 000),
     1 IMOD(0:GM,1:2)
      CHARACTER*3 CFLG
      DOUBLECOMPLEX CJ,CY
      EXTERNAL CJ,CY,SZEIC,LSZEIC
C
      INTEGER STDIN,STDOUT,STDERR
      COMMON /STDIO/ STDIN,STDOUT,STDERR
      COMMON /KONST/ C0,MUE,EPS0,PI

      integer :: jDum
C
      C0= 2.997925E+08
      RDUM= 1.
      PI= 4.0*ATAN(RDUM)
      MUE= 4.0 * PI * 1.0E-7
      EPS0= 1.0/(MUE * C0**2)
      STDIN= 10
      STDOUT= 11
      STDERR= 12
      OPEN (STDIN, FILE= 'DeviceDescription')
      OPEN (STDERR,FILE='STDERR')
      READ (STDIN,*) EMB,MODES,SCAL,IGN,ISCAL,MAZI,RQ,RA,RB,ISTEP,CFLG
      IF (MODES .LT. 1) THEN
         WRITE (0,*) ' modes .lt. 1'
         STOP
      ENDIF
      Q= 1.
      IF (MAZI .NE. 0) THEN
         WRITE (0,*) ' mazi /= 0'
         WRITE (*,*) ' mazi /= 0'
         STOP
      ENDIF
      IF (CFLG .EQ. 'ZRP') THEN
         ICFLG= 0
      ELSE IF (CFLG .EQ. 'RTP') THEN
         ICFLG= 1
      ELSE
         WRITE (0,*)
     1 ' FBILD: CFLG .NE. ''ZRP'' .AND. CFLG .NE. ''RTP'' ',CFLG
         STOP ' KAZI'
      ENDIF
      BETA= 1.D0 - DBLE(EMB)
C IF (EMB .LT. 0.) BETA= -1.D0 + DBLE(EMB)
      MATRIX= 0
      IF (IGN .GT. GM) CALL ErrorStop(' IGN too large.')
      READ (STDIN,*)   ! Skip the 'vor solve0'
      DO 10 I= 0, IGN, 1
         READ (STDIN,*) R(I), DZ(I), EPS(I)
      WRITE (0,*) R(I), DZ(I),EPS(I)
   10 CONTINUE
C
      IF (ICFLG .EQ. 0) THEN
         RQ= RQ*SCAL
         DO 20 I= 0, IGN, 1
            R(I)= R(I)*SCAL
            DZ(I)= DZ(I)*SCAL
   20 CONTINUE
      ELSE
C
C Kugelkoordinaten
C
         RDUM= PI/180.
         RQ= RQ*RDUM
         DO 30 I= 0, IGN, 1
            R(I)= R(I)*RDUM
            DZ(I)= DZ(I)*SCAL
   30 CONTINUE
      ENDIF
C
      READ (STDIN,*)
      READ (STDIN,*) IFREQ, FKNA, FKNE
      WRITE (0,*) ' iFreq, fkna, fkne:', IFREQ, FKNA, FKNE
      READ (STDIN,*)
      READ (STDIN,*)
      READ (STDIN,*)
      READ (STDIN,*) ITM,ITE
      WRITE (0,*) ITM
C
      tMax= 60; izStp= 280;
      Nullf= 0.5
      FaktL= 3.0; FaktR= 3.0
      rZMin= -1000; rZMax= 1000
      ncv= 31; lSymm= 0
      cT= 0e-2
      pStep= 21; nBar= 2; Breite= 1.3; Dichte= 3.25; Winkel= 22.5;
      xMax= 122.; yMax= 29.7; xText= 23.0; yText= 32.0;
      hText= 1.7; wText= 0.0
      dyText= 1.5;
      sl1= 10.0; sl2= 1.0; zwl= 3.0
      if (0==1) then
         OPEN (20,FILE='FBILD.PAR', STATUS= 'OLD')
      READ (20,*) TMAX,IZSTP,NULLF,FAKTL,FAKTR,RZMIN,RZMAX,NCV,LSYMM
         READ (20,*)
         READ (20,*) CT
         READ (20,*)
         READ (20,*) PSTEP,NBAR,BREITE,DICHTE,WINKEL,
     1    XMAX,YMAX,XTEXT,YTEXT,HTEXT,WTEXT,DYTEXT,
     2    SL1,SL2,ZWL
         CLOSE (20)
      end if
      DYT= DYTEXT*HTEXT
C
      IF (MODES .GT. LDA) CALL ErrorStop(' MODES too large.')
      IF (IGN .GT. GM) CALL ErrorStop(' IGN too large.')
    !!  IF (IFREQ .GT. MF) CALL ErrorStop(' IFREQ too large.')
      CLOSE (STDIN)
C
C DEFINE the eigenvalues
C
C if there is no azimuthal function, the TE Fields are zero
C and we compute twice as much TM coefficients
C
      CALL DEFJM (JM ,MODES,MAZI)
      CALL DEFJMS(JMS,MODES,MAZI)
C
C Calculation of the ABSolute area bounds from the DELTA-Z
C
      IF (ICFLG .EQ. 0) THEN
         ZM1= -DZ(0)
         Z(0)= 0.
      ELSE
         ZM1= 0.
         Z(0)= DZ(0)
      ENDIF
      DO 100 I= 1, IGN, 1
         Z(I)= Z(I-1) + DZ(I)
  100 CONTINUE
      Z(IGN+1)= Z(IGN)
C
      ISRC1= 1
      ISRC2= 2
      IF (ICFLG .NE. 0) THEN
         ISRC1= 2
         ISRC2= 2
      ENDIF
 !!     DO 8000 ISRC= ISRC1, ISRC2, 1
      DO 8000 ISRC= 1, 1, 1  ! 2013-05-17
      if= 1
    !!  DO 1000 IF= 1, IFREQ
         IF ((ICFLG .EQ. 0) .AND. (ISRC .EQ. 2)) THEN
            !
            ! Ueberspringen des 'source free'.
            !
            READ (*,'(A)') STR
      WRITE (0,*) STR
            Q= 0.
         ENDIF
         IF (ICFLG .NE. 0) THEN
            Q= 0.
         ENDIF
         READ (*,*)
         READ (*,'(A)') Str
      WRITE (0,'(1X,99A)') ' kr0-String:', trim(STR)
         READ (Str,*) KR0
      WRITE (0,*) ' k*r0:',KR0
         RDUM= R(0)
         IF (ICFLG .EQ. 1) RDUM= Z(0)
         PHASE= EXP(DCMPLX(RNULL, CT*KR0/RDUM))
      WRITE (*,*) '# phase:',PHASE
!!      PHASE= 1.
         READ (*,'(A)') STR
      WRITE (0,*) STR
         DO 1030 N= 0, IGN, 1
            READ (*,'(A)') STR
      WRITE (0,*) STR
            READ (*,*) ATM(1,N,IF), ATM(2,N,IF)
            READ (*,*) BTM(1,N,IF), BTM(2,N,IF)
            IF (ISRC .EQ. ISRC2) THEN
               ATM(1,N,IF)= 0.
               BTM(1,N,IF)= 0.
               ATM(2,N,IF)= 0.
               BTM(2,N,IF)= 0.
            ELSE
               ATM(1,N,IF)= ATM(1,N,IF)*PHASE
               BTM(1,N,IF)= BTM(1,N,IF)*PHASE
               ATM(2,N,IF)= ATM(2,N,IF)*PHASE
               BTM(2,N,IF)= BTM(2,N,IF)*PHASE
            ENDIF
            READ (*,'(A)') STR
      WRITE (0,*) STR
            READ (*,*) jDum, IMOD(N,1)
      if (Mazi == 0) iMod(n,1)= jDum
            IDUM= 1
            IF (MAZI .NE. 0) IDUM= 2
            DO IITM= 1, IDUM, 1
               DO J= 1, IMOD(N,1), 1
                  READ (*,*) C(J,IITM,N,IF),LAMBDA(J,IITM,N,IF)
                  IF (ABS(KR0) .LT. 1.0E-3)
     1 C(J,IITM,N,IF)= C(J,IITM,N,IF)*NULLF
                  C(J,IITM,N,IF)= C(J,IITM,N,IF)*PHASE
               END DO
            END DO
            READ (*,'(A)') STR
      WRITE (0,*) STR
            READ (*,*) jDum, IMOD(N,2)
      if (Mazi == 0) iMod(n,2)= jDum
            DO 1051 IITM= 1, IDUM, 1
               DO 1050 J= 1, IMOD(N,2), 1
      READ (*,'(A)') STR
      write (0,'(2I3, 1X, A)') iitm, j, STR(:len_trim(Str))
                  READ (str,*) D(J,IITM,N,IF)
                !!  READ (*,*) D(J,IITM,N,IF)
                  IF (ABS(KR0) .LT. 1.0E-3)
     1 D(J,IITM,N,IF)= D(J,IITM,N,IF)*NULLF
                  D(J,IITM,N,IF)= D(J,IITM,N,IF)*PHASE
 1050 CONTINUE
 1051 CONTINUE
 1030 CONTINUE
 1000 CONTINUE
C
      WRITE (0,*) ' do 1060 ..', iFreq, ign
      DO 1060 IF= 1, IFREQ
         k= (FKNA + (IF-1)*(FKNE-FKNA) / MAX(IFREQ-1,1))/r(0)
C WELLENZAHL
         PHASE= ZEXP(DCMPLX(RNULL, K*CT))
 1060 CONTINUE
      WRITE (0,*) ' nach do 1060 ..', iFreq, ign

      IDUM= ICFLG
      IDUM= 0
      IF (IDUM .EQ. 0) THEN
         B= RQ
         DO 2010 N= 0, IGN, 1
            B= MAX(B, R(N))
 2010 CONTINUE
      write (0,*) ' iGN, r(0:ign):', iGN, r(0:ign)
         ZW1= MAX(RZMIN, Z(0)-0.75*R(0)*FAKTL)
         ZW2= MIN(RZMAX, Z(IGN-1)+0.75*R(IGN)*FAKTR)
C
C BERECHNEN DER H-WERTE BEI Z= ZW(1)..ZW(2)
C UND R= RA..RB
C
         !
         ! B ist das Maximum aller Radien.
         ! TMAX ist der erste Parameter in der Datei 'FBILD.PAR'
         ! Der Wert ist TMAX=60
         !
       !!  RB= MIN(TMAX*3.141592654/180.,B)
         RB= B
         RA= 0.0001*RB
         RFAKT= 1.
         ZFAKT= RFAKT
         Z(IGN)= Z(IGN-1)+0.75*R(IGN)*FAKTR
C
         RDZ= (ZW2-ZW1)/FLOAT(IZSTP-1)
         WORK(1)= ZW1
         DO 2020 I= 2, IZSTP, 1
            WORK(I)= WORK(I-1)+RDZ
 2020 CONTINUE
         DO 2030 I= 0, IGN-1, 1
            WORK(IZSTP+3*I+1)= Z(I)+SIGN(0.01*RDZ,R(I+1)-R(I))
            WORK(IZSTP+3*I+2)= Z(I)+SIGN(0.1*RDZ,R(I+1)-R(I))
            WORK(IZSTP+3*I+3)= Z(I)
 2030 CONTINUE
      WRITE (0,*) ' call qsort()..',IZSTP+3*IGN
         CALL QSORT(IZSTP+3*IGN,WORK,IND)
      WRITE (0,*) ' nach call qsort()..'
         IZSTEP= 0
         DO 2040 I= 1, IZSTP+3*IGN, 1
            IF (WORK(IND(I)) .GT. RZMIN) THEN
               IZSTEP= IZSTEP+1
               ZARR(IZSTEP)= WORK(IND(I))
               IF (ZARR(IZSTEP) .GT. RZMAX) GOTO 2050
            ENDIF
 2040 CONTINUE
 2050 CONTINUE
      ISTP= IZSTEP*RB/(2.*ZARR(IZSTEP))
    !!  WRITE (0,*) ' nach 2040'
C
         DR= ABS(RB-RA)/FLOAT(ISTP-1)
      WRITE (0,*) ' dr, rB, rA:', dR, rB, rA
      WRITE (0,*) ' iStp:', iStp
         WORK(1)= RA
         DO 2060 I= 2, ISTP, 1
            WORK(I)= WORK(I-1)+DR
 2060 CONTINUE
         WORK(ISTP+1)= RQ-0.01*DR
         WORK(ISTP+2)= RQ+0.01*DR
         ISTP= ISTP+2
         JGN= 0
      if (1==1) then
         DO I= 0, IGN, 1
            IF (Z(I) .GT. RZMAX) CYCLE
            IF (Z(I) .LT. RZMIN) CYCLE
            JGN= JGN+2
            WORK(ISTP+2*I+1)= R(I)-0.01*DR
            WORK(ISTP+2*I+2)= R(I)-0.1*DR
         END DO
      end if
      WRITE (0,*) ' nach 2070'
         CALL QSORT(ISTP+JGN,WORK,IND)
      WRITE (0,*) ' nach 2070 qsort'
         J= 1
         RARR(1)= WORK(IND(1))
      WRITE (0,*) ' do 2080 ..'
         DO 2080 I= 2, ISTP+JGN, 1
            IF (ABS(WORK(IND(I))-WORK(IND(I-1))) .GT. 0.0001*DR) THEN
               J= J+1
               RARR(J)= WORK(IND(I))
            ENDIF
 2080 CONTINUE
      WRITE (0,*) ' nach 2080..IZSTEP,ISTP',IZSTEP,ISTP
         ISTEP= J
C
        !! IF (ISRC .EQ. 2) THEN
         IF (.true.) THEN
            IF (ICFLG .NE. 0) THEN
               WRITE (*,9031) MODES,K*Z(0),K*Z(0)*SIN(R(0)),CT
 9031 FORMAT(
     2 '% toplabel= " " subtitle= "modes=',I3,
     3 '  k*r0=',F9.4,'  k*r0*sin(theta0)=',F8.4,
     4 '  c*t=',F8.4,'"',/,
     4 '% xlabel= " " ylabel= " " sidelabel= False',/,
     6 '% equalscale= True',/,
     7 '% comment= "no comment"',/
     8 )
               RZA= RZMIN
               T= 0.
               DO 2200 NJ= 0, IGN, 1
                  IF (Z(NJ) .LT. RZMIN) GOTO 2200
                  IF (Z(NJ) .GT. RZMAX) GOTO 2200
                  R1= RZA
                  T= R(NJ)
                  X1= R1*COS(T)
                  Y1= R1*SIN(T)
                  R2= Z(NJ)
                  X2= R2*COS(T)
                  Y2= R2*SIN(T)
                  WRITE (*,9020) X1,Y1,X2,Y2
                  IF (NJ .NE. IGN) THEN
                     CALL ARC(Z(NJ),R(NJ),R(NJ+1))
                  END IF
C
                  IF (LSYMM .NE. 0) THEN
                     WRITE (*,9020) X1,-Y1,X2,-Y2
                     IF (NJ .NE. IGN) THEN
                        CALL ARC(Z(NJ),-R(NJ),-R(NJ+1))
                     END IF
                  ENDIF
                  RZA= R2
                  T= R(NJ+1)
 2200 CONTINUE
               IF (T .NE. 0.) THEN
                  R1= RZA
                  X1= R1*COS(T)
                  Y1= R1*SIN(T)
                  R2= ZARR(IZSTEP)
                  X2= R2*COS(T)
                  Y2= R2*SIN(T)
                  WRITE (*,9020) X1, Y1, X2, Y2
C
                  IF (LSYMM .NE. 0) THEN
                     WRITE (*,9020) X1,-Y1,X2,-Y2
                  END IF
               ENDIF
            ENDIF
      WRITE (0,*) ' call hzn()..'
            NALT= -1
            DO 2090 I= 1, IZSTEP, 1
               RDUM= ZARR(I)
               !
               ! Suchen nach dem Gebiet, in dem diese z-Kooordinate liegt.
               !
               DO 2100 II= 0, IGN-1, 1
                  IF (RDUM .LT. Z(II)) THEN
                     N= II
                     GOTO 2110
                  ENDIF
 2100          CONTINUE
               N= IGN
 2110       CONTINUE
               IF (ICFLG .EQ. 0) THEN
      WRITE (0,*) ' i, izStep, N:', I, IZSTEP, n
      WRITE (0,*) ' iMod(n,1:2):', iMod(N,1:2)
                  CALL HZNN(IMOD(N,1),IMOD(N,2),N,
     1 C(1,1,N,1),C(1,2,N,1),
     2 D(1,1,N,1),D(1,2,N,1),JM,JMS,MAZI,
     1 LAMBDA(1,1,N,1),LAMBDA(1,2,N,1),
     4 ZARR(I),4,ISTEP,
     2 RARR,WERTE((I-1)*ISTEP+1),
     3 ATM(1,N,1),BTM(1,N,1),
     4 R(0),Z(0),EPS(0))
               ELSE
      WRITE (0,*) I,IZSTEP,N,IMOD(N,1),IMOD(N,2)
                  IF (N .NE. NALT)
     1 CALL KHPA(IMOD(N,1),IMOD(N,2),N,
     1 C(1,1,N,1),C(1,2,N,1),
     3 D(1,1,N,1),D(1,2,N,1),MAZI,
     1 ZARR(I),RARR,ISTEP,
     1 LAMBDA(1,1,N,1),LAMBDA(1,2,N,1),4,
     2 WERTE((I-1)*ISTEP+1),
     4 R(0),Z(0),
     5 NALT,RLEG1,RLEG2,RLEG3,RLEG3,MODES)
                  CALL KHPA(IMOD(N,1),IMOD(N,2),N,
     1 C(1,1,N,1),C(1,2,N,1),
     3 D(1,1,N,1),D(1,2,N,1),MAZI,
     1 ZARR(I),RARR,ISTEP,
     1 LAMBDA(1,1,N,1),LAMBDA(1,2,N,1),4,
     2 WERTE((I-1)*ISTEP+1),
     4 R(0),Z(0),
     5 NALT,RLEG1,RLEG2,RLEG3,RLEG3,MODES)
                  IF (MAZI .EQ. 0) THEN
                     DO 2120 IR= 1, ISTEP, 1
                        WERTE((I-1)*ISTEP+IR)=
     1 WERTE((I-1)*ISTEP+IR)*ZARR(I)*SIN(RARR(IR))
 2120 CONTINUE
                  ENDIF
               ENDIF
 2090 CONTINUE
            WMAX= -1.E20
            WMIN= +1.E20
            DO 8010 J= 1, IZSTEP*ISTEP, 1
               RDUM= WERTE(J)
               IF (RDUM .NE. 0.) THEN
                  WMAX= MAX(WMAX,RDUM)
                  WMIN= MIN(WMIN,RDUM)
               ENDIF
 8010 CONTINUE
            IDN= 1
            DO 8030 N= -1, IGN-1, IDN
      WRITE (0,*) N,IGN
               IF (N .EQ. -1) THEN
                  IZA= 1
                  RDUM= MIN(Z(IDN-1),ZARR(IZSTEP-1))
                  DO 8040 I= IZA, IZSTEP, 1
                     IF (ZARR(I) .EQ. RDUM) GOTO 8050
 8040 CONTINUE
      WRITE (0,*) ' z-wert nicht gefunden:',RDUM
                  GOTO 8999
 8050 CONTINUE
                  IZE= I
               ELSE IF (N .EQ. IGN) THEN
                  IZE= IZSTEP
                  RDUM= MAX(Z(MAX(N-IDN,0)),ZARR(1))
                  DO 8060 I= IZE, 1, -1
                     IF (ZARR(I) .EQ. RDUM) GOTO 8070
 8060 CONTINUE
      WRITE (0,*) ' z-wert nicht gefunden2:',RDUM
                  GOTO 8999
 8070 CONTINUE
                  IZA= I
               ELSE
                  RDUM= MAX(Z(N),ZARR(1))
                  DO 8080 I= IZSTEP, 1, -1
                     IF (ZARR(I) .EQ. RDUM) GOTO 8090
 8080 CONTINUE
      WRITE (0,*) ' z-wert nicht gefunden3:',RDUM
                  GOTO 8999
 8090 CONTINUE
                  IZA= I
                  RDUM= MIN(Z(MIN(N+IDN,IGN)),ZARR(IZSTEP-1))
                  DO 8091 I= IZA, IZSTEP, 1
                     IF (ZARR(I) .EQ. RDUM) GOTO 8092
 8091 CONTINUE
      WRITE (0,*) ' z-wert nicht gefunden4:',RDUM
                  GOTO 8999
 8092 CONTINUE
                  IZE= I
               ENDIF
               DO 8093 I= ISTEP, 1, -1
                  IF (WERTE(I+(IZA-1)*ISTEP) .NE. 0.) GOTO 8094
 8093 CONTINUE
               GOTO 8999
 8094 CONTINUE
               IRA= 1
               IRE= I
               IF (ICFLG .EQ. 0) THEN
                  RDUM= MAX(WMAX,ABS(WMIN))
                  WRITE (*,9008) MODES, KR0, RARR(ISTEP)*1.2,
     1 WMAX,WMIN,RDUM,-RDUM,
     1 IZE-IZA+1,(ZFAKT*ZARR(I),I=IZA,IZE,1)
                  IF (LSYMM .NE. 0) THEN
                     WRITE (*,9009)
     1 2*(IRE-IRA+1)+1,(-RFAKT*RARR(I),I=IRE,IRA,-1),0.,
     2 (RFAKT*RARR(I),I=IRA,IRE, 1)
                  ELSE
                     WRITE (*,9009) IRE-IRA+1+1,0.,
     1 (RFAKT*RARR(I),I=IRA,IRE, 1)
                  ENDIF
 9008 FORMAT(
     1 '$ DATA= CONTOUR',/
     2 '% toplabel= " " subtitle= "modes=',I2,'  k*r0= ',F8.4,'"',/,
     3 '% xlabel= " " ylabel= " " sidelabel= False',/,
     4 '% ymin= 0.0 ymax= ',E12.6,/,
     5 '% equalscale= True',/,
     6 '% comment= "comment: cmax= ',E12.6,' cmin=',E12.6,'"',/,
     2 '% interp= 2',/,
     3 '% nsteps= 40',/,
     4 '% linetypes= 1',/,
     5 '% contlabel= False',/,'% sidelabel= False',/,
     6 '% contclip= False',/,
     7 '% contstyle= 1',/,
     8 '% splinetype= 0',/,
     9 '# cmax=  2.0e+10',/,
     A '# cmin= -2.0e+10',/,
     9 '% cmax=',E12.6,/,
     A '% cmin=',E12.6,/,
     1 '% boundary= False',//,
     2 '% nx=',I4,' xgrid= True',/,
     3 100(10(1H ,E12.6),/),/)
 9009 FORMAT(/,
     1 '% ny=',I4,' ygrid= True',/,
     2 100(10(1H ,E12.6),/),//)
C WRITE (*,9010)
 9010 FORMAT(
     1 '$ DATA= CONTCURVE',/
     2 )
                  IF (LSYMM .NE. 0)
     1 WRITE (*,'(/,10000(10(1H ,E13.6),/))')
     1 ((WERTE(II+(JJ-1)*ISTEP),JJ=IZA,IZE,1),II=IRE,IRA,-1)
                  WRITE (*,'(/,10000(10(1H ,E13.6),/))')
     1 (0. ,JJ=IZA,IZE,1),
     2 ((WERTE(II+(JJ-1)*ISTEP),JJ=IZA,IZE,1),II=IRA,IRE,1)
                  NJ= N
      if (nj == -1) then
         WRITE (*,9020) rzMin, R(0), Z(0), R(0)
      end if
                  IF (NJ .LE. -1) GOTO 8100
C DO 8100 NJ= 0, iGN, 1
                     IF (Z(NJ) .LT. RZMIN) GOTO 8100
                     IF (Z(NJ) .GT. RZMAX) GOTO 8100
                     IF (NJ .NE. IGN) THEN
                        WRITE (*,9020) Z(NJ),R(NJ),Z(NJ),R(NJ+1)
                        WRITE (*,9020) Z(NJ),R(NJ+1),Z(NJ+1),R(NJ+1)
C
                        IF (LSYMM .NE. 0) THEN
                           WRITE (*,9020) Z(NJ),-R(NJ),Z(NJ),-R(NJ+1)
                         WRITE (*,9020) Z(NJ),-R(NJ+1),Z(NJ+1),-R(NJ+1)
                        ENDIF
                     ENDIF
 8100 CONTINUE
 9020 FORMAT(
     1 '@ line x1=',E12.6,' y1=',E12.6,' x2=',E12.6,' y2=',E12.6,
     2 ' linewidth= 2 linetype= 1, absolute= False'
     3 )
               ELSE
C
C Kugelkoordinaten
C
                  NXDIM= ISTEP
                  NX= IRE-IRA+1
                  NY= IZE-IZA+1
                  RDUM= MAX(WMAX,ABS(WMIN))
                  IF (NX*NY/30+1 .GT. 1 000 000) THEN
                     WRITE (0,*) ' ibitmp ist zu klein..'
                     STOP
                  ENDIF
                  DO 8130 II= 1, NCV, 1
       WRITE (0,*) ' call gcontr(..)..',NX,NY,II,NCV
                     RDUM= MAX(WMAX,ABS(WMIN))
                     RCV= -RDUM+(II-1)*2.*RDUM/FLOAT(NCV-1)
                     RDUM= 2.*MAX(WMAX,ABS(WMIN))
                     CALL GCONTR(WERTE(IRA+(IZA-1)*ISTEP),NXDIM,NX,NY,
     1 RCV,1,RDUM,IBITMP,SZEIC)
                     IF (LSYMM .NE. 0)
     1 CALL GCONTR(WERTE(IRA+(IZA-1)*ISTEP),NXDIM,NX,NY,
     2 RCV,1,RDUM,IBITMP,LSZEIC)
 8130 CONTINUE
               ENDIF
 8999 CONTINUE
 8030 CONTINUE
         ENDIF
      ELSE
C
C Kugelkoordinaten
C
      WRITE (0,*) ' Kugelkoordinaten'
         ZW1= MAX(RZMIN,Z(0)-0.75*Z(0)*SIN(R(0))*FAKTL)
         ZW2= MIN(RZMAX,Z(IGN-1)+0.75*Z(IGN-1)*SIN(R(IGN))*FAKTR)
         B= MAX(Z(N-1)*SIN(R(IGN)),ZW2*SIN(R(IGN)))
         DO 3010 N= 0, IGN-1, 1
            B= MAX(B, ZW2*SIN(R(N)), Z(N)*SIN(R(N)))
 3010 CONTINUE
C
C BERECHNEN DER H-WERTE BEI Z= ZW(1)..ZW(2)
C UND R= RA..RB
C
         RB= B
         RA= 0.0001*RB
         RFAKT= 1.
         ZFAKT= RFAKT
         Z(IGN)= Z(IGN-1)+0.75*Z(IGN-1)*SIN(R(IGN))*FAKTR
C
         RDZ= (ZW2-ZW1)/FLOAT(IZSTP-1)
         WORK(1)= ZW1
         DO 3020 I= 2, IZSTP, 1
            WORK(I)= WORK(I-1)+RDZ
 3020 CONTINUE
      WRITE (0,*) ' call qsort()..',IZSTP
         CALL QSORT(IZSTP,WORK,IND)
      WRITE (0,*) ' nach call qsort()..'
         IZSTEP= 0
         DO 3040 I= 1, IZSTP, 1
            IF (WORK(IND(I)) .GT. RZMIN) THEN
               IZSTEP= IZSTEP+1
               ZARR(IZSTEP)= WORK(IND(I))
               IF (ZARR(IZSTEP) .GT. RZMAX) GOTO 3050
            ENDIF
 3040 CONTINUE
 3050 CONTINUE
         DR= ABS(RB-RA)/FLOAT(ISTP-1)
         WORK(1)= RA
         DO 3060 I= 2, ISTP, 1
            WORK(I)= WORK(I-1)+DR
 3060 CONTINUE
         CALL QSORT(ISTP,WORK,IND)
         DO 3080 I= 1, ISTP, 1
            RARR(I)= WORK(IND(I))
 3080 CONTINUE
         ISTEP= ISTP
      WRITE (0,*) ' call khp()..'
         DO 3090 I= 1, IZSTEP, 1
      WRITE (0,*) I,IZSTEP
            DO 3100 IR= 1, ISTEP, 1
               RADIUS= SQRT(ZARR(I)**2 + RARR(IR)**2)
               WINKEL= ATAN2(RARR(IR),ZARR(I))
               DO 3110 II= 0, IGN-1, 1
                  IF (RADIUS .LT. Z(II)) THEN
                     N= II
                     GOTO 3120
                  ENDIF
 3110 CONTINUE
               N= IGN
 3120 CONTINUE
               IMODS= MODES
               IF (N .NE. IGN)
     1 IMODS= MAX(1,MIN(MODES,INT(MODES*R(N)/R(N+1))))
               CALL KHP(IMODS,N,C(1,1,N,1),C(1,2,N,1),
     1 D(1,1,N,1),D(1,2,N,1),MAZI,
     1 RADIUS,WINKEL,
     1 LAMBDA(1,1,N,1),LAMBDA(1,2,N,1),4,
     2 WERTE((I-1)*ISTEP+IR),
     4 R(0),Z(0))
               WERTE((I-1)*ISTEP+IR)=
     1 WERTE((I-1)*ISTEP+IR)*RARR(IR)
 3100 CONTINUE
 3090 CONTINUE
         WMAX= -1.E20
         WMIN= +1.E20
         DO 4010 J= 1, IZSTEP*ISTEP, 1
            RDUM= WERTE(J)
            IF (RDUM .NE. 0.) THEN
               WMAX= MAX(WMAX,RDUM)
               WMIN= MIN(WMIN,RDUM)
            ENDIF
 4010 CONTINUE
         IRA= 1
         IRE= ISTEP
         IZA= 1
         IZE= IZSTEP
         RDUM= MAX(WMAX,ABS(WMIN))
         WRITE (*,9030) MODES,K*Z(0),K*Z(0)*SIN(R(0)),RARR(ISTEP)*1.2,
     1 WMAX,WMIN,RDUM,-RDUM,
     1 IZE-IZA+1,(ZFAKT*ZARR(I),I=IZA,IZE,1)
 9030 FORMAT(
     1 '$ DATA= CONTOUR',/
     2 '% toplabel= " " subtitle= "modes=',I2,
     3 '  k*r0= ',F8.4,'  k*r0*sin(theta0)= ',F8.4,'"',/,
     4 '% xlabel= " " ylabel= " " sidelabel= False',/,
     5 '% ymin= 0.0 ymax= ',E12.6,/,
     6 '% equalscale= True',/,
     7 '% comment= "comment: cmax= ',E12.6,' cmin=',E12.6,'"',/,
     8 '% interp= 2',/,
     9 '% nsteps= 40',/,
     1 '% linetypes= 1',/,
     1 '% contlabel= False',/,'% sidelabel= False',/,
     2 '% contclip= False',/,'% contstyle= 1',/,
     3 '% splinetype= 0',/,
     4 '# cmax=  2.0e+10',/,'# cmin= -2.0e+10',/,
     5 '% cmax=',E12.6,/,'% cmin=',E12.6,/,
     6 '% boundary= False',//,
     7 '% nx=',I4,' xgrid= True',/,
     8 100(10(1H ,E12.6),/),/)
         IF (LSYMM .NE. 0) THEN
            WRITE (*,9009)
     1 2*(IRE-IRA+1)+1,(-RFAKT*RARR(I),I=IRE,IRA,-1),0.,
     2 (RFAKT*RARR(I),I=IRA,IRE, 1)
         ELSE
            WRITE (*,9009) IRE-IRA+1+1,0.,
     1 (RFAKT*RARR(I),I=IRA,IRE, 1)
         ENDIF
         IF (LSYMM .NE. 0)
     1 WRITE (*,'(/,10000(10(1H ,E12.6),/))')
     1 ((WERTE(II+(JJ-1)*ISTEP),JJ=IZA,IZE,1),II=IRE,IRA,-1)
         WRITE (*,'(/,10000(10(1H ,E12.6),/))')
     1 (0. ,JJ=IZA,IZE,1),
     2 ((WERTE(II+(JJ-1)*ISTEP),JJ=IZA,IZE,1),II=IRA,IRE,1)
         DO 4020 NJ= 0, IGN, 1
            IF (Z(NJ) .LT. RZMIN) GOTO 4020
            IF (Z(NJ) .GT. RZMAX) GOTO 4020
            IF (NJ .NE. 0) THEN
               R1= MAX(ZARR(IZA),Z(NJ-1))
            ELSE
               R1= ZARR(1)
            ENDIF
            T= R(NJ)
            X1= R1*COS(T)
            Y1= R1*SIN(T)
            IF (NJ .NE. IGN) THEN
               R2= MIN(ZARR(IZE),Z(NJ))
            ELSE
               R2= ZARR(IZE)
            ENDIF
            X2= R2*COS(T)
            Y2= R2*SIN(T)
            WRITE (*,9020) X1,Y1,X2,Y2
            IF (NJ .NE. IGN) CALL ARC(Z(NJ),R(NJ),R(NJ+1))
C
            IF (LSYMM .NE. 0) THEN
               WRITE (*,9020) X1,-Y1,X2,-Y2
               IF (NJ .NE. IGN) CALL ARC(Z(NJ),-R(NJ),-R(NJ+1))
            ENDIF
 4020 CONTINUE
      ENDIF
C
 8000 CONTINUE
C
      WRITE (*,9990)
 9990 FORMAT('$ END')
      RETURN
      END
C ***********
      SUBROUTINE ARC(R,T1,T2)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
      IEND= MAX(2, NINT(ABS(T2-T1)*180./3.141592654))
      DO 10 I= 1, IEND-1, 1
         PHI1= T1+(I-1)*(T2-T1)/(IEND-1)
         PHI2= T1+ I *(T2-T1)/(IEND-1)
         X1= R*COS(PHI1)
         Y1= R*SIN(PHI1)
         X2= R*COS(PHI2)
         Y2= R*SIN(PHI2)
         WRITE (*,9020) X1,Y1,X2,Y2
   10 CONTINUE
 9020 FORMAT(
     1 '@ line x1=',E12.6,' y1=',E12.6,' x2=',E12.6,' y2=',E12.6,
     2 ' linewidth= 2 linetype= 1, absolute= False'
     3 )
      RETURN
      END
C **************
      SUBROUTINE SZEIC(XR,YZ,IFLAG)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
      COMMON /CDRAW/ IRA,IZA,RARR(10 000), ZARR(10 000)
C
C WRITE (0,*) 'sdraw:',XR,YZ,IFLAG
      IH= IFLAG/10
      IL= MOD(IFLAG,10)
      IF (IL .GT. 5) RETURN
C
      IXR= XR
      FXR= XR-IXR
      IXR= IXR+IRA-1
      IYZ= YZ
      FYZ= YZ-IYZ
      IYZ= IYZ+IZA-1
      T= (1.-FXR)*RARR(IXR)+FXR*RARR(IXR+1)
      R= (1.-FYZ)*ZARR(IYZ)+FYZ*ZARR(IYZ+1)
      X= R*COS(T)
      Y= R*SIN(T)
C
      IPEN= 2
      IF ((IL .NE. 2) .AND. (IL .NE. 3)) GOTO 10
C
C Start einer Contourlinie
C
      IPEN= 3
C
   10 CONTINUE
      CALL PLOT(X,Y,IPEN)
      RETURN
      END
C ********
      SUBROUTINE LSZEIC(XR,YZ,IFLAG)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
      COMMON /CDRAW/ IRA,IZA,RARR(10 000), ZARR(10 000)
C
C WRITE (0,*) 'lsdraw:',XR,YZ,IFLAG
      IH= IFLAG/10
      IL= MOD(IFLAG,10)
      IF (IL .GT. 5) RETURN
C
      IXR= XR
      FXR= XR-IXR
      IXR= IXR+IRA-1
      IYZ= YZ
      FYZ= YZ-IYZ
      IYZ= IYZ+IZA-1
      T= (1.-FXR)*RARR(IXR)+FXR*RARR(IXR+1)
      R= (1.-FYZ)*ZARR(IYZ)+FYZ*ZARR(IYZ+1)
      X= R*COS(T)
      Y= -R*SIN(T)
C
      IPEN= 2
      IF ((IL .NE. 2) .AND. (IL .NE. 3)) GOTO 10
C
C Start einer Contourlinie
C
      IPEN= 3
C
   10 CONTINUE
      CALL PLOT(X,Y,IPEN)
      RETURN
      END
C ********
      SUBROUTINE PLOT(X,Y,IPEN)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
      DOUBLEPRECISION XA,YA
      SAVE XA,YA
C
      IF (IPEN .EQ. 2) THEN
C
C Zeichnen einer Verbindungslinie zum Zielpunkt
C
         WRITE (*,'(2(E12.6,1H ))') X,Y
      ELSE IF (IPEN .EQ. 3) THEN
C
C Positionieren auf den neuen Zielpunkt
C
           WRITE (*,'(/,2(E12.6,1H ))') X,Y
      ELSE
         WRITE (0,*) ' plot: ipen hat illegalen Wert:',IPEN
         STOP
      ENDIF
      XA= X
      YA= Y
      RETURN
      END
!********
      SUBROUTINE MNULL(N,LDA,M)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER N,LDA
      DOUBLECOMPLEX M(LDA,*)
C
      INTEGER I
      DO 10 I= 1, N
         CALL VNULL(N,M(1,I))
   10 CONTINUE
      RETURN
      END
C ****************************
      SUBROUTINE VNULL(N,M)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER N
      DOUBLECOMPLEX M(*)
C
      INTEGER I
      DO 10 I= 1, N
         M(I)= (0.0, 0.0)
   10 CONTINUE
      RETURN
      END
C hznn.f
      SUBROUTINE HZNN(IC,ID,N,CTM,CTE,DTM,DTE,JM,JMS,MAZI,
     & QTM,QTE,ZA,N2,ISTEP,RARR,ZARR,
     2 ATM,BTM,
     3 R,Z,EPS)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
      DOUBLECOMPLEX CTM(*),DTM(*),QTM(*),
     & CTE(*),DTE(*),QTE(*)
      DOUBLEPRECISION JM(*),JMS(*),ZA,RARR(*),ZARR(*),R(0:*),Z(0:*)
      DOUBLECOMPLEX ATM(2),BTM(2),EPS(0:*)
C
      DOUBLEPRECISION K,RQ
      DOUBLE PRECISION BETA
      COMMON /VIEL2/ BETA,K,RQ
      INTEGER STDIN,STDOUT,STDERR
      COMMON /STDIO/ STDIN,STDOUT,STDERR
      DOUBLEPRECISION C,MUE,EPS0,PI
      COMMON /KONST/ C,MUE,EPS0,PI
C
      DOUBLEPRECISION ZAMZNM
      DOUBLECOMPLEX FWERT
      DIMENSION BESJ(0:102),CEM(100),CEE(100)
      EXTERNAL ZJM,ZYM,ZJMS,ZYMS
C
C DAS SYSTEM WIRD NICHT FUER DIE ORIGINALKOEFFIZIENTEN AUFGESTELLT
C UND GELOEST, SONDERN FUER HILFKOEFFIZIENTEN
C CTX'(N,S)= CTX(N,S)*EXP(+IM*QTX(S,N)*Z(N-1))
C DTX'(N,S)= DTX(N,S)*EXP(-IM*QTX(S,N)*Z(N  ))
C
      OMEGA= K * C
      FAKTOR= 2.*PI*R(0) / MUE
      M= MAZI
      MP2= M + 2
      IF (N .EQ. 0) THEN
         ZAMZNM= ZA-Z(0)
      ELSE
         ZAMZNM= ZA-Z(N-1)
      ENDIF
      IF (N2 .EQ. 3) THEN
C WRITE (*,*) ' 2.*PI*R(0)* H RHO / Q'
         CEM0= - M * EXP((0.,-1.) * K/BETA*ZA)
     & * EPS(N) * K**2
         DO 3 I= 1, IC, 1
            IF (MAZI .NE. 0)
     1 CEE(I)= ( CTE(I)*EXP((0., 1.)*QTE(I)* ZAMZ NM)
     2 - DTE(I)*EXP((0.,-1.)*QTE(I)*(ZA-Z(N )))
     3 ) * (0., 1.)*QTE(I)
            CEM(I)= - M
     1 * ( CTM(I)*EXP((0., 1.)*QTM(I)* ZAMZ NM)
     2 + DTM(I)*EXP((0.,-1.)*QTM(I)*(ZA-Z(N )))
     3 ) * EPS(N) * K**2
    3 CONTINUE
      ELSE IF (N2 .EQ. 4) THEN
C WRITE (*,*) ' 2.*PI*R(0)* H PHI / Q'
         CEM0= - EXP((0., -1.) * K / BETA * ZA)
     1           * K**2
         DO I= 1, IC, 1
            IF (MAZI .NE. 0) THEN
               CEE(I)= ( CTE(I)*EXP((0., 1.)*QTE(I)* ZAMZ NM)
     2                 - DTE(I)*EXP((0.,-1.)*QTE(I)*(ZA-Z(N )))
     3                 ) * M * (0., 1.)*QTE(I)
            END IF
            CEM(I)= - (CTM(I)*EXP((0., 1.)*QTM(I)* ZAMZ NM)
     1               + DTM(I)*EXP((0.,-1.)*QTM(I)*(ZA-Z(N )))
     2                ) * EPS(N) * K**2
         END DO
      ELSE
         CALL ErrorStop(' HZNN: (N2 .LT. 1) .OR. (N2 .GT. 4)')
      ENDIF
      DO 10 I= 1, ISTEP, 1
         RL= RARR(I)
         IF (RL .GT. R(N)) THEN
            ZARR(I)= 0.
         ELSE
         FWERT= 0.
         IF (N2 .EQ. 3) THEN
C BR:
            DO 24 J= 1, IC, 1
C BR TEI * RL:
               IF (MAZI .NE. 0) THEN
                  X= JMS(J) * RL / R(N)
                  CALL C335(X, MP2, BESJ(0))
                  FWERT= FWERT + (M*BESJ(M)-X*BESJ(M+1))*CEE(J)
               ENDIF
C BR TMI * RL:
               X= JM(J) * RL / R(N)
               CALL C335(X, MP2, BESJ(0))
               FWERT= FWERT + BESJ(M) * CEM(J)
   24 CONTINUE
            FWERT= FWERT / RL
         ELSE IF (N2 .EQ. 4) THEN
C BP:
            DO 26 J= 1, IC, 1
C BP TEI * RL:
               IF (MAZI .NE. 0) THEN
                  X= JMS(J) * RL / R(N)
                  CALL C335(X, MP2, BESJ(0))
                  FWERT= FWERT + BESJ(M) * CEE(J)
               ENDIF
C BP TMI * RL:
               X= JM(J) * RL / R(N)
               CALL C335(X, MP2, BESJ(0))
               FWERT= FWERT + (M*BESJ(M)-X*BESJ(M+1))*CEM(J)
   26       CONTINUE
            FWERT= FWERT / RL
         ENDIF
         J= 2
         IF (RL .LT. RQ) J= 1
         CDUM= 1.D0 - 1.D0 / BETA**2
         ZARG= RL * K * SQRT( CDUM )
         ZDUM= ZYMS(M, ZARG)
         IF (N2 .EQ. 3) THEN
C BR TMS:
            FWERT= FWERT
     &           + CEM0 * (ATM(J) * ZJM(M,ZARG)
     &                   + BTM(J) * ZYM(M,ZARG)) / RL
         ELSE IF (N2 .EQ. 4) THEN
C BP TMS:
            FWERT= FWERT
     &           + CEM0 * (ATM(J) * ZJMS(M,ZARG)
     &                   + BTM(J) * ZYMS(M,ZARG)
     &                    ) * ZARG / RL
         ENDIF
C WRITE (IAUS,*) RL
C WRITE (IAUS,*) FWERT * FAKTOR
            ZARR(I)= RL * FWERT * FAKTOR
         ENDIF
   10 CONTINUE
 9999 CONTINUE
      RETURN
      END
C khp.f
      SUBROUTINE KHP(MODEN,N,CTM,CTE,DTM,DTE,MAZI,
     1 RADIUS,WINKEL,
     2 QTM,QTE,N2A,BP,R,Z)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
      DOUBLECOMPLEX CTM(*),DTM(*),QTM(*),
     1 CTE(*),DTE(*),QTE(*)
      DIMENSION R(0:*)
      DOUBLEPRECISION Z(0:*)
C
      INTEGER EGM
      PARAMETER (EGM=800)
      DOUBLEPRECISION K,RQ
      DOUBLE PRECISION BETA
      COMMON /VIEL2/ BETA,K,RQ
      INTEGER STDIN,STDOUT,STDERR
      COMMON /STDIO/ STDIN,STDOUT,STDERR
      DOUBLEPRECISION C,MUE,EPS,PI
      COMMON /KONST/ C,MUE,EPS,PI
      COMMON /CIGN/ IGN
C
      DOUBLEPRECISION ZAMZNM
      DOUBLECOMPLEX FWERT
      DIMENSION CEM(100),CEE(100)
      EXTERNAL RLGF,RLGFS,CRR,CRRSR
C
C WRITE (STDERR,*) ' KFKNT2: N,QTM,QTE:',N,(QTM(I),I=1,MODEN),
C & (QTE(I),I=1,MODEN)
      OMEGA= K * C
      FAKTOR= 2.*PI*R(0)*EPS*C
      M= MAZI
      MP2= M + 2
C
      N2= 1000
      IF (N2A .EQ. 3) N2= 4
      IF (N2A .EQ. 4) N2= 3
      BP= 0.
      IF (N2 .EQ. 3) THEN
C WRITE (IAUS,*) ISTEP,' ''proportional zu B phi'''
      ELSE IF (N2 .EQ. 4) THEN
         IF (MAZI .EQ. 0) RETURN
C WRITE (IAUS,*) ISTEP,' ''proportional zu B theta'''
      ELSE
         CALL ErrorStop(' KFKNT2: (N2a .GT. 4) ')
      ENDIF
C
      CK= RADIUS
      CDUM= K*RADIUS
      IF (N .EQ. 0) THEN
         CDUMC = K*Z(N )
         CDUMD = K*Z(N )
      ELSE IF (N .EQ. IGN) THEN
         CDUMC = K*Z(N-1)
         CDUMD = K*Z(N-1)
      ELSE
         CDUMC = K*Z(N-1)
         CDUMD = K*Z(N )
      ENDIF
      RKQ= K**2
      DO 1 I= 1, MODEN, 1
         CEM(I)= RKQ*(
     1 CTM(I)*CRR (N,1,QTM(I),CDUM,CDUMC)
     2 + DTM(I)*CRR (N,2,QTM(I),CDUM,CDUMD)
     3 )
C 4 *DIMAG(QTM(I))
         IF (MAZI .NE. 0)
     1 CEE(I)= - (CTE(I)*CRRSR(N,1,QTE(I),CDUM,CDUMC,CK)
     1 + DTE(I)*CRRSR(N,2,QTE(I),CDUM,CDUMD,CK)
     2 )
C 3 *DIMAG(QTE(I))
    1 CONTINUE
C
      RMUE= DBLE(MAZI)
      TEF= 1.
      FWERT= 0.
      RL= WINKEL
      IF (RL .GT. R(N)) RETURN
      STHETA= SIN(RL)
      STHETI= 1./STHETA
      IF (N2 .EQ. 4) THEN
C B theta:
         DO 20 J= 1, MODEN
C B theta TM
            FWERT= FWERT - CEM(J) * RLGF (RL,QTM(J),RMUE) * STHETI
     1 * RMUE
   20 CONTINUE
         DO 21 J= 1, MODEN
C B theta TE
            FWERT= FWERT + CEE(J) * RLGFS(RL,QTE(J),RMUE) * STHETI
     1*TEF
   21 CONTINUE
      ELSE IF (N2 .EQ. 3) THEN
C BP:
         DO 22 J= 1, MODEN
C BP TM
            FWERT= FWERT - CEM(J) * RLGFS(RL,QTM(J),RMUE) * STHETI
   22 CONTINUE
         IF (MAZI .NE. 0) THEN
         DO 23 J= 1, MODEN
C BP TE
            FWERT= FWERT + CEE(J) * RLGF (RL,QTE(J),RMUE) * STHETI
     1 * RMUE
     2*TEF
   23 CONTINUE
         ENDIF
      ENDIF
C WRITE (IAUS,*) RL*180./3.141592654
C WRITE (IAUS,*) FWERT
      BP= FWERT
C
      RETURN
      END
C khpa.f
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE KHPA(IC,ID,N,CTM,CTE,DTM,DTE,MAZI,
     1 RADIUS,WINKEL,ISTEP,
     2 QTM,QTE,N2A,BP,R,Z,
     3 NALT,RLEGM,RLEGE,RLEGMS,RLEGES,LDR)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
      DOUBLECOMPLEX CTM(*),DTM(*),QTM(*),
     1 CTE(*),DTE(*),QTE(*)
      DIMENSION R(0:*),WINKEL(*),BP(*),
     2 RLEGM(LDR,*),RLEGE(LDR,*),RLEGMS(LDR,*),RLEGES(LDR,*)
      DOUBLEPRECISION Z(0:*)
C
      INTEGER EGM
      PARAMETER (EGM=800)
      DOUBLEPRECISION K,RQ
      DOUBLE PRECISION BETA
      COMMON /VIEL2/ BETA,K,RQ
      INTEGER STDIN,STDOUT,STDERR
      COMMON /STDIO/ STDIN,STDOUT,STDERR
      DOUBLEPRECISION C,MUE,EPS,PI
      COMMON /KONST/ C,MUE,EPS,PI
      COMMON /CIGN/ IGN
      COMMON /CISRC/ ISRC
      COMMON /CITM/ ITM,ITE
C
      DOUBLEPRECISION ZAMZNM
      DOUBLECOMPLEX FWERT
      DIMENSION CEM(300),CEE(300)
      EXTERNAL RLGF,RLGFS,CRR,CRRSR
C
      OMEGA= K * C
      FAKTOR= 2.*PI*R(0)*EPS*C
      M= MAZI
      MP2= M + 2
C
      N2= 1000
      IF (N2A .EQ. 3) N2= 4
      IF (N2A .EQ. 4) N2= 3
      IF (N2 .EQ. 3) THEN
C WRITE (IAUS,*) ISTEP,' ''proportional zu B phi'''
      ELSE IF (N2 .EQ. 4) THEN
         IF (MAZI .EQ. 0) RETURN
C WRITE (IAUS,*) ISTEP,' ''proportional zu B theta'''
      ELSE
         CALL ErrorStop(' KHPA: (N2a .GT. 4) ')
      ENDIF
C
      CK= RADIUS
      CDUM= K*RADIUS
      IF (N .EQ. 0) THEN
         CDUMC = K*Z(N )
         CDUMD = K*Z(N )
      ELSE IF (N .EQ. IGN) THEN
         CDUMC = K*Z(N-1)
         CDUMD = K*Z(N-1)
      ELSE
         CDUMC = K*Z(N-1)
         CDUMD = K*Z(N )
      ENDIF
      RKQ= K**2
      DO 1 I= 1, IC, 1
         IF (N .EQ. IGN) ISRC= 0
         IF (N .EQ. 0) ISRC= ITM-I
C write (0,*) n,radius,DOUBLEPRECISION(cdum),DOUBLEPRECISION(cdumc),DOUBLEPRECISION(cdumd)
         CEM(I)= RKQ*(
     1 CTM(I)*CRR (N,1,QTM(I),CDUM,CDUMC,CK)
     2 + DTM(I)*CRR (N,2,QTM(I),CDUM,CDUMD,CK)
     3 )
         IF (MAZI .NE. 0) THEN
         IF (N .EQ. IGN) ISRC= 0
         IF (N .EQ. 0) ISRC= ITE-I
         CEE(I)= - (CTE(I)*CRRSR(N,1,QTE(I),CDUM,CDUMC,CK)
     1 + DTE(I)*CRRSR(N,2,QTE(I),CDUM,CDUMD,CK)
     2 )
         ENDIF
    1 CONTINUE
C
      RMUE= DBLE(MAZI)
      TEF= 1.
      DO 10 I= 1, ISTEP, 1
         FWERT= 0.
         RL= WINKEL(I)
         IF (RL .GT. R(N)) THEN
            BP(I)= 0.
            GOTO 10
         ENDIF
         STHETA= SIN(RL)
         STHETI= 1./STHETA
         IF (N2 .EQ. 4) THEN
C B theta:
            DO 20 J= 1, IC, 1
C B theta TM
               IF (NALT .NE. N)
     1 RLEGM(J,I)= RLGF (RL,QTM(J),RMUE) * STHETI * RMUE
               FWERT= FWERT - CEM(J) * RLEGM(J,I)
   20 CONTINUE
            DO 21 J= 1, IC, 1
C B theta TE
               IF (NALT .NE. N)
     1 RLEGE(J,I)= RLGFS(RL,QTE(J),RMUE) * STHETI
               FWERT= FWERT + CEE(J) * RLEGE(J,I)
   21 CONTINUE
         ELSE IF (N2 .EQ. 3) THEN
C BP:
            DO 22 J= 1, IC, 1
C BP TM
               IF (NALT .NE. N)
     1 RLEGM(J,I)= RLGFS(RL,QTM(J),RMUE) * STHETI
               FWERT= FWERT - CEM(J) * RLEGM(J,I)
   22 CONTINUE
            IF (MAZI .NE. 0) THEN
            DO 23 J= 1, IC, 1
C BP TE
               IF (NALT .NE. N)
     1 RLEGE(J,I)= RLGF (RL,QTE(J),RMUE) * STHETI * RMUE
               FWERT= FWERT + CEE(J) * RLEGE(J,I)
   23 CONTINUE
            ENDIF
         ENDIF
C WRITE (IAUS,*) RL*180./3.141592654
C WRITE (IAUS,*) FWERT
         BP(I)= FWERT * (0.,1.)
   10 CONTINUE
C
      NALT= N
      RETURN
      END
C schrfl.f
      SUBROUTINE SCHRFL(IF,GN,ZFAKT,RFAKT,
     & BREITE,WINKEL,DICHTE,NBAR,Z,R,ZW1)
C IMPLICIT CHARACTER*1 (A-Z)
      IMPLICIT NONE
      INTEGER IF,GN,NBAR
      DOUBLEPRECISION ZFAKT,RFAKT,BREITE,WINKEL,DICHTE,Z(*),R(*),ZW1
C
C ZEICHNE EINE SCHRAFFUR LINKS DER KONTUR,
C GEGEBEN DURCH R(I) UND Z(I), I=1, GN
C
C ES WIRD EINE DATEI ERZEUGT, DIE SPAETER VON 'INTERP'
C INTERPRETIERT UND IN 'GRIPS'-AUFRUFE UMGESETZT WIRD.
C
      INTEGER I,IL,IR
      DOUBLEPRECISION HOEHE,RMAX
C
   10 FORMAT('  PLOT'/2F9.4,I3)
      RMAX= 0.
      WRITE (IF,10) 0., RFAKT*R(1), 3
      DO 20 I= 1, GN, 1
         RMAX= MAX(RMAX,ABS(RFAKT*R(I)))
         WRITE (IF,10) ZFAKT*(Z(I)-ZW1), RFAKT*R(I), 2
         IF (I .NE. GN) WRITE (IF,10) ZFAKT*(Z(I)-ZW1),RFAKT*R(I+1),2
   20 CONTINUE
      RMAX= RMAX+HOEHE
      HOEHE= BREITE
      RMAX= RMAX+HOEHE
   30 FORMAT('  BAR'/6F9.4,I3)
      WRITE (IF,30) 0., RFAKT*R(1), ZFAKT*(Z(1)-ZW1), HOEHE,
     & DICHTE, WINKEL, NBAR
   31 FORMAT('  RAHMEN'/4F9.4)
      DO 40 I= 1, GN-1, 1
         IL= MAX(I-1,1)
         IR= MIN(I+1,GN)
C
C
C HORIZONTALE SCHRAFFUR:
         WRITE (IF,31) 0.,0.,ZFAKT*(Z(GN)-ZW1),RMAX
         WRITE (IF,30) ZFAKT*(Z(I)-ZW1),
     & RFAKT*R(IR),
     & ZFAKT*(Z(IR)-Z(I)),
     & HOEHE,
     & DICHTE,WINKEL,NBAR
C
C
C VERTIKALE SCHRAFFUR:
         WRITE (IF,31) ZFAKT*(Z(IL)-ZW1),0.,
     & ZFAKT*(Z(IR)-ZW1),
     & RMAX
         IF (R(I+1) .GT. R(I)) THEN
            WRITE (IF,30) ZFAKT*(Z(I)-ZW1)-BREITE,
     & RFAKT*R(I)+HOEHE,
     & BREITE,
     & RFAKT*(R(IR)-R(I)),
     & DICHTE,WINKEL,NBAR
         ELSE
            WRITE (IF,30) ZFAKT*(Z(I)-ZW1),
     & RFAKT*R(IR)+HOEHE,
     & BREITE,
     & RFAKT*(R(I)-R(IR)),
     & DICHTE,WINKEL,NBAR
         ENDIF
   40 CONTINUE
      RETURN
      END
C *************************
      SUBROUTINE SMBL(IF,X,Y,H,ITEXT,W,DYT)
      DOUBLEPRECISION X,Y,H,W,DYT
      INTEGER IF
      CHARACTER*(*) ITEXT
C
   10 FORMAT('  SYMBOL'/3F9.4,' ''',A,'''',F9.4,' 150')
C if (1 .ne. 0) return
      WRITE (IF,10) X,Y,H,ITEXT,W
      Y= Y+DYT*COS(W*17.453293E-3)
      X= X-DYT*SIN(W*17.453293E-3)
      RETURN
      END
C ***********************
      SUBROUTINE COUT(Z)
      DOUBLECOMPLEX Z
C
      INTEGER STDIN,STDOUT,STDERR
      COMMON /STDIO/ STDIN,STDOUT,STDERR
      WRITE (STDOUT,*) RE AL(Z),DIMAG(Z)
      RETURN
      END
C ***********************
      SUBROUTINE CGET(Z)
      DOUBLECOMPLEX Z
C
      INTEGER STDIN,STDOUT,STDERR
      COMMON /STDIO/ STDIN,STDOUT,STDERR
      DOUBLEPRECISION R,I
      READ (STDIN,*) R,I
      Z= DCMPLX(R,I)
      RETURN
      END
C a531.f
      SUBROUTINE FILL0(BITMAP, N)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
C FILL THE FIRST N BITS OF BITMAP WITH ZEROES.
C
      INTEGER BITMAP(*), N
C
      DATA NBPW /30/
C NBPW IS THE MINIMUM NUMBER OF SIGNIFICANT BITS PER WORD USED
C BY INTEGER ARITHMETIC. THIS IS USUALLY ONE LESS THAN THE
C ACTUAL NUMBER OF BITS PER WORD, BUT AN IMPORTANT EXCEPTION IS
C THE CDC-6000 SERIES OF MACHINES, WHERE NBPW SHOULD BE 48.
C
      LOOP = N/NBPW
      NBLW = MOD(N,NBPW)
      IF (LOOP.EQ.0) GO TO 20
      DO 10 I=1,LOOP
        BITMAP(I) = 0
   10 CONTINUE
   20 IF (NBLW.NE.0) BITMAP(LOOP+1) = MOD(BITMAP(LOOP+1),2**(NBPW-NBLW)
     * )
      RETURN
      END
C *********
      SUBROUTINE MARK1(BITMAP, N)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
C PUT A ONE IN THE NTH BIT OF BITMAP.
C
      INTEGER BITMAP(*), N
C
      DATA NBPW /30/
C NBPW IS THE MINIMUM NUMBER OF SIGNIFICANT BITS PER WORD USED
C BY INTEGER ARITHMETIC. THIS IS USUALLY ONE LESS THAN THE
C ACTUAL NUMBER OF BITS PER WORD, BUT AN IMPORTANT EXCEPTION IS
C THE CDC-6000 SERIES OF MACHINES, WHERE NBPW SHOULD BE 48.
C
      NWORD = (N-1)/NBPW
      NBIT = MOD(N-1,NBPW)
      I = 2**(NBPW-NBIT-1)
      BITMAP(NWORD+1) = BITMAP(NWORD+1) + I*(1-MOD(BITMAP(NWORD+1)/I,2)
     * )
      RETURN
      END
C ********
      FUNCTION IGET(BITMAP, N)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
C IGET=0 IF THE NTH BIT OF BITMAP IS ZERO, ELSE IGET IS ONE.
C
      INTEGER BITMAP(*), N
C
      DATA NBPW /30/
C NBPW IS THE MINIMUM NUMBER OF SIGNIFICANT BITS PER WORD USED
C BY INTEGER ARITHMETIC. THIS IS USUALLY ONE LESS THAN THE
C ACTUAL NUMBER OF BITS PER WORD, BUT AN IMPORTANT EXCEPTION IS
C THE CDC-6000 SERIES OF MACHINES, WHERE NBPW SHOULD BE 48.
C
      NWORD = (N-1)/NBPW
      NBIT = MOD(N-1,NBPW)
      IGET = MOD(BITMAP(NWORD+1)/2**(NBPW-NBIT-1),2)
      RETURN
      END
C ******
      SUBROUTINE GCONTR(Z, NRZ, NX, NY, CV, NCV, ZMAX, BITMAP, DRAW)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
C THIS SUBROUTINE DRAWS A CONTOUR THROUGH EQUAL VALUES OF AN ARRAY.
C
C ***** FORMAL ARGUMENTS ***********************************
C
C Z IS THE ARRAY FOR WHICH CONTOURS ARE TO BE DRAWN. THE ELEMENTS
C OF Z ARE ASSUMED TO LIE UPON THE NODES OF A TOPOLOGICALLY
C RECTANGULAR COORDINATE SYSTEM - E.G. CARTESIAN, POLAR (EXCEPT
C THE ORIGIN), ETC.
C
C NRZ IS THE NUMBER OF ROWS DECLARED FOR Z IN THE CALLING PROGRAM.
C
C NX IS THE LIMIT FOR THE FIRST SUBSCRIPT OF Z.
C
C NY IS THE LIMIT FOR THE SECOND SUBSCRIPT OF Z.
C
C CV ARE THE VALUES OF THE CONTOURS TO BE DRAWN.
C
C NCV IS THE NUMBER OF CONTOUR VALUES IN CV.
C
C ZMAX IS THE MAXIMUM VALUE OF Z FOR CONSIDERATION. A VALUE OF
C Z(I,J) GREATER THAN ZMAX IS A SIGNAL THAT THAT POINT AND THE
C GRID LINE SEGMENTS RADIATING FROM THAT POINT TO IT'S NEIGHBORS
C ARE TO BE EXCLUDED FROM CONTOURING.
C
C BITMAP IS A WORK AREA LARGE ENOUGH TO HOLD 2*NX*NY*NCV BITS. IT
C IS ACCESSED BY LOW-LEVEL ROUTINES, WHICH ARE DESCRIBED BELOW.
C LET J BE THE NUMBER OF USEFUL BITS IN EACH WORD OF BITMAP,
C AS DETERMINED BY THE USER MACHINE AND IMPLEMENTATION OF
C THE BITMAP MANIPULATION SUBPROGRAMS DESCRIBED BELOW. THEN
C THE NUMBER OF WORDS REQUIRED FOR THE BITMAP IS THE FLOOR OF
C (2*NX*NY*NCV+J-1)/J.
C
C DRAW IS A USER-PROVIDED SUBROUTINE USED TO DRAW CONTOURS.
C THE CALLING SEQUENCE FOR DRAW IS:
C
C CALL DRAW (X,Y,IFLAG)
C LET NX = INTEGER PART OF X, FX = FRACTIONAL PART OF X.
C THEN X SHOULD BE INTERPRETED SUCH THAT INCREASES IN NX
C CORRESPOND TO INCREASES IN THE FIRST SUBSCRIPT OF Z, AND
C FX IS THE FRACTIONAL DISTANCE FROM THE ABSCISSA CORRESPONDING
C TO NX TO THE ABSCISSA CORRESPONDING TO NX+1,
C AND Y SHOULD BE INTERPRETED SIMILARLY FOR THE SECOND
C SUBSCRIPT OF Z.
C THE LOW-ORDER DIGIT OF IFLAG WILL HAVE ONE OF THE VALUES:
C 1 - CONTINUE A CONTOUR,
C 2 - START A CONTOUR AT A BOUNDARY,
C 3 - START A CONTOUR NOT AT A BOUNDARY,
C 4 - FINISH A CONTOUR AT A BOUNDARY,
C 5 - FINISH A CLOSED CONTOUR (NOT AT A BOUNDARY).
C NOTE THAT REQUESTS 1, 4 AND 5 ARE FOR PEN-DOWN
C MOVES, AND THAT REQUESTS 2 AND 3 ARE FOR PEN-UP
C MOVES.
C 6 - SET X AND Y TO THE APPROXIMATE 'PEN' POSITION, USING
C THE NOTATION DISCUSSED ABOVE. THIS CALL MAY BE
C IGNORED, THE RESULT BEING THAT THE 'PEN' POSITION
C IS TAKEN TO CORRESPOND TO Z(1,1).
C IFLAG/10 IS THE CONTOUR NUMBER.
C
C ***** EXTERNAL SUBPROGRAMS *******************************
C
C DRAW IS THE USER-SUPPLIED LINE DRAWING SUBPROGRAM DESCRIBED ABOVE.
C DRAW MAY BE SENSITIVE TO THE HOST COMPUTER AND TO THE PLOT DEVICE.
C FILL0 IS USED TO FILL A BITMAP WITH ZEROES. CALL FILL0 (BITMAP,N)
C FILLS THE FIRST N BITS OF BITMAP WITH ZEROES.
C MARK1 IS USED TO PLACE A 1 IN A SPECIFIC BIT OF THE BITMAP.
C CALL MARK1 (BITMAP,N) PUTS A 1 IN THE NTH BIT OF THE BITMAP.
C IGET IS USED TO DETERMINE THE SETTING OF A PARTICULAR BIT IN THE
C BITMAP. I=IGET(BITMAP,N) SETS I TO ZERO IF THE NTH BIT OF THE
C BITMAP IS ZERO, AND SETS I TO ONE IF THE NTH BIT IS ONE.
C FILL0, MARK1 AND IGET ARE MACHINE SENSITIVE.
C
C ******************************************************************
C
      DOUBLEPRECISION Z(NRZ,1), CV(1)
      INTEGER BITMAP(1)
      INTEGER L1(4), L2(4), IJ(2)
C
C L1 AND L2 CONTAIN LIMITS USED DURING THE SPIRAL SEARCH FOR THE
C BEGINNING OF A CONTOUR.
C IJ STORES SUBCRIPTS USED DURING THE SPIRAL SEARCH.
C
      INTEGER I1(2), I2(2), I3(6)
C
C I1, I2 AND I3 ARE USED FOR SUBSCRIPT COMPUTATIONS DURING THE
C EXAMINATION OF LINES FROM Z(I,J) TO IT'S NEIGHBORS.
C
      DOUBLEPRECISION XINT(4)
C
C XINT IS USED TO MARK INTERSECTIONS OF THE CONTOUR UNDER
C CONSIDERATION WITH THE EDGES OF THE CELL BEING EXAMINED.
C
      DOUBLEPRECISION XY(2)
C
C XY IS USED TO COMPUTE COORDINATES FOR THE DRAW SUBROUTINE.
C
      EQUIVALENCE (L2(1),IMAX), (L2(2),JMAX), (L2(3),IMIN),
     * (L2(4),JMIN)
      EQUIVALENCE (IJ(1),I), (IJ(2),J)
      EQUIVALENCE (XY(1),X), (XY(2),Y)
C
      DATA L1(3) /-1/, L1(4) /-1/
      DATA I1 /1,0/, I2 /1,-1/, I3 /1,0,0,1,1,0/
C
      L1(1) = NX
      L1(2) = NY
      DMAX = ZMAX
C
C SET THE CURRENT PEN POSITION. THE DEFAULT POSITION CORRESPONDS
C TO Z(1,1).
C
      X = 1.0
      Y = 1.0
      CALL DRAW(X, Y, 6)
      ICUR = MAX0(1,MIN0(INT(X),NX))
      JCUR = MAX0(1,MIN0(INT(Y),NY))
C
C CLEAR THE BITMAP
C
      CALL FILL0(BITMAP, 2*NX*NY*NCV)
C
C SEARCH ALONG A RECTANGULAR SPIRAL PATH FOR A LINE SEGMENT HAVING
C THE FOLLOWING PROPERTIES:
C 1. THE END POINTS ARE NOT EXCLUDED,
C 2. NO MARK HAS BEEN RECORDED FOR THE SEGMENT,
C 3. THE VALUES OF Z AT THE ENDS OF THE SEGMENT ARE SUCH THAT
C ONE Z IS LESS THAN THE CURRENT CONTOUR VALUE, AND THE
C OTHER IS GREATER THAN OR EQUAL TO THE CURRENT CONTOUR
C VALUE.
C
C SEARCH ALL BOUNDARIES FIRST, THEN SEARCH INTERIOR LINE SEGMENTS.
C NOTE THAT THE INTERIOR LINE SEGMENTS NEAR EXCLUDED POINTS MAY BE
C BOUNDARIES.
C
      IBKEY = 0
   10 I = ICUR
      J = JCUR
   20 IMAX = I
      IMIN = -I
      JMAX = J
      JMIN = -J
      IDIR = 0
C DIRECTION ZERO IS +I, 1 IS +J, 2 IS -I, 3 IS -J.
   30 NXIDIR = IDIR + 1
      K = NXIDIR
      IF (NXIDIR.GT.3) NXIDIR = 0
   40 I = IABS(I)
      J = IABS(J)
      IF (Z(I,J).GT.DMAX) GO TO 140
      L = 1
C L=1 MEANS HORIZONTAL LINE, L=2 MEANS VERTICAL LINE.
   50 IF (IJ(L).GE.L1(L)) GO TO 130
      II = I + I1(L)
      JJ = J + I1(3-L)
      IF (Z(II,JJ).GT.DMAX) GO TO 130
      ASSIGN 100 TO JUMP
C THE NEXT 15 STATEMENTS (OR SO) DETECT BOUNDARIES.
   60 IX = 1
      IF (IJ(3-L).EQ.1) GO TO 80
      II = I - I1(3-L)
      JJ = J - I1(L)
      IF (Z(II,JJ).GT.DMAX) GO TO 70
      II = I + I2(L)
      JJ = J + I2(3-L)
      IF (Z(II,JJ).LT.DMAX) IX = 0
   70 IF (IJ(3-L).GE.L1(3-L)) GO TO 90
   80 II = I + I1(3-L)
      JJ = J + I1(L)
      IF (Z(II,JJ).GT.DMAX) GO TO 90
      IF (Z(I+1,J+1).LT.DMAX) GO TO JUMP, (100, 280)
   90 IX = IX + 2
      GO TO JUMP, (100, 280)
  100 IF (IX.EQ.3) GO TO 130
      IF (IX+IBKEY.EQ.0) GO TO 130
C NOW DETERMINE WHETHER THE LINE SEGMENT IS CROSSED BY THE CONTOUR.
      II = I + I1(L)
      JJ = J + I1(3-L)
      Z1 = Z(I,J)
      Z2 = Z(II,JJ)
      DO 120 ICV=1,NCV
        IF (IGET(BITMAP,2*(NX*(NY*(ICV-1)+J-1)+I-1)+L).NE.0) GO TO 120
        IF (CV(ICV).LE.DMIN1(Z1,Z2)) GO TO 110
        IF (CV(ICV).LE.DMAX1(Z1,Z2)) GO TO 190
  110 CALL MARK1(BITMAP, 2*(NX*(NY*(ICV-1)+J-1)+I-1)+L)
  120 CONTINUE
  130 L = L + 1
      IF (L.LE.2) GO TO 50
  140 L = MOD(IDIR,2) + 1
      IJ(L) = ISIGN(IJ(L),L1(K))
C
C LINES FROM Z(I,J) TO Z(I+1,J) AND Z(I,J+1) ARE NOT SATISFACTORY.
C CONTINUE THE SPIRAL.
C
  150 IF (IJ(L).GE.L1(K)) GO TO 170
      IJ(L) = IJ(L) + 1
      IF (IJ(L).GT.L2(K)) GO TO 160
      GO TO 40
  160 L2(K) = IJ(L)
      IDIR = NXIDIR
      GO TO 30
  170 IF (IDIR.EQ.NXIDIR) GO TO 180
      NXIDIR = NXIDIR + 1
      IJ(L) = L1(K)
      K = NXIDIR
      L = 3 - L
      IJ(L) = L2(K)
      IF (NXIDIR.GT.3) NXIDIR = 0
      GO TO 150
  180 IF (IBKEY.NE.0) RETURN
      IBKEY = 1
      GO TO 10
C
C AN ACCEPTABLE LINE SEGMENT HAS BEEN FOUND.
C FOLLOW THE CONTOUR UNTIL IT EITHER HITS A BOUNDARY OR CLOSES.
C
  190 IEDGE = L
      CVAL = CV(ICV)
      IF (IX.NE.1) IEDGE = IEDGE + 2
      IFLAG = 2 + IBKEY
      XINT(IEDGE) = (CVAL-Z1)/(Z2-Z1)
  200 XY(L) = FLOAT(IJ(L)) + XINT(IEDGE)
      XY(3-L) = FLOAT(IJ(3-L))
      CALL MARK1(BITMAP, 2*(NX*(NY*(ICV-1)+J-1)+I-1)+L)
      CALL DRAW(X, Y, IFLAG+10*ICV)
      IF (IFLAG.LT.4) GO TO 210
      ICUR = I
      JCUR = J
      GO TO 20
C
C CONTINUE A CONTOUR. THE EDGES ARE NUMBERED CLOCKWISE WITH
C THE BOTTOM EDGE BEING EDGE NUMBER ONE.
C
  210 NI = 1
      IF (IEDGE.LT.3) GO TO 220
      I = I - I3(IEDGE)
      J = J - I3(IEDGE+2)
  220 DO 250 K=1,4
        IF (K.EQ.IEDGE) GO TO 250
        II = I + I3(K)
        JJ = J + I3(K+1)
        Z1 = Z(II,JJ)
        II = I + I3(K+1)
        JJ = J + I3(K+2)
        Z2 = Z(II,JJ)
        IF (CVAL.LE.DMIN1(Z1,Z2)) GO TO 250
        IF (CVAL.GT.DMAX1(Z1,Z2)) GO TO 250
        IF (K.EQ.1) GO TO 230
        IF (K.NE.4) GO TO 240
  230 ZZ = Z1
        Z1 = Z2
        Z2 = ZZ
  240 XINT(K) = (CVAL-Z1)/(Z2-Z1)
        NI = NI + 1
        KS = K
  250 CONTINUE
      IF (NI.EQ.2) GO TO 260
C
C THE CONTOUR CROSSES ALL FOUR EDGES OF THE CELL BEING EXAMINED.
C CHOOSE THE LINES TOP-TO-LEFT AND BOTTOM-TO-RIGHT IF THE
C INTERPOLATION POINT ON THE TOP EDGE IS LESS THAN THE INTERPOLATION
C POINT ON THE BOTTOM EDGE. OTHERWISE, CHOOSE THE OTHER PAIR. THIS
C METHOD PRODUCES THE SAME RESULTS IF THE AXES ARE REVERSED. THE
C CONTOUR MAY CLOSE AT ANY EDGE, BUT MUST NOT CROSS ITSELF INSIDE
C ANY CELL.
C
      KS = 5 - IEDGE
      IF (XINT(3).LT.XINT(1)) GO TO 260
      KS = 3 - IEDGE
      IF (KS.LE.0) KS = KS + 4
C
C DETERMINE WHETHER THE CONTOUR WILL CLOSE OR RUN INTO A BOUNDARY
C AT EDGE KS OF THE CURRENT CELL.
C
  260 L = KS
      IFLAG = 1
      ASSIGN 280 TO JUMP
      IF (KS.LT.3) GO TO 270
      I = I + I3(KS)
      J = J + I3(KS+2)
      L = KS - 2
  270 IF (IGET(BITMAP,2*(NX*(NY*(ICV-1)+J-1)+I-1)+L).EQ.0) GO TO 60
      IFLAG = 5
      GO TO 290
  280 IF (IX.NE.0) IFLAG = 4
  290 IEDGE = KS + 2
      IF (IEDGE.GT.4) IEDGE = IEDGE - 4
      XINT(IEDGE) = XINT(KS)
      GO TO 200
C
      END
C ../lib/qsort.f
      SUBROUTINE QSORT (N,X, IND)
      IMPLICIT DOUBLEPRECISION (A-H, O-Z)
      INTEGER N, IND(*)
      DOUBLEPRECISION X(*)
C
C***********************************************************
C
C ROBERT RENKA
C OAK RIDGE NATL. LAB.
C (615) 576-5139
C
C THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO
C SORT THE DOUBLEPRECISION ARRAY X INTO INCREASING ORDER. THE ALGOR-
C ITHM IS AS FOLLOWS. IND IS INITIALIZED TO THE ORDERED
C SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES ARE
C APPLIED TO IND. X IS DIVIDED INTO TWO PORTIONS BY PICKING
C A CENTRAL ELEMENT T. THE FIRST AND LAST ELEMENTS ARE COM-
C PARED WITH T, AND INTERCHANGES ARE APPLIED AS NECESSARY SO
C THAT THE THREE VALUES ARE IN ASCENDING ORDER. INTER-
C CHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS GREATER THAN
C T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS
C LESS THAN T ARE IN THE LOWER PORTION. THE UPPER AND LOWER
C INDICES OF ONE OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS,
C AND THE PROCESS IS REPEATED ITERATIVELY ON THE OTHER
C PORTION. WHEN A PORTION IS COMPLETELY SORTED, THE PROCESS
C BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER
C UNSORTED PORTION.
C
C INPUT PARAMETERS - N - LENGTH OF THE ARRAY X.
C
C X - VECTOR OF LENGTH N TO BE SORTED.
C
C IND - VECTOR OF LENGTH .GE. N.
C
C N AND X ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N
C PERMUTED IN THE SAME FASHION AS X
C WOULD BE. THUS, THE ORDERING ON
C X IS DEFINED BY Y(I) = X(IND(I)).
C
C MODULES REFERENCED BY QSORT - NONE
C
C INTRINSIC FUNCTIONS CALLED BY QSORT - IFIX, FLOAT
C
C***********************************************************
C
C NOTE -- IU AND IL MUST BE DIMENSIONED .GE. LOG(N) WHERE
C LOG HAS BASE 2.
C
C***********************************************************
C
      INTEGER IU(21), IL(21)
      INTEGER M, I, J, K, L, IJ, IT, ITT, INDX
      DOUBLEPRECISION R, T
C
C LOCAL PARAMETERS -
C
C IU,IL = TEMPORARY STORAGE FOR THE UPPER AND LOWER
C INDICES OF PORTIONS OF THE ARRAY X
C M = INDEX FOR IU AND IL
C I,J = LOWER AND UPPER INDICES OF A PORTION OF X
C K,L = INDICES IN THE RANGE I,...,J
C IJ = RANDOMLY CHOSEN INDEX BETWEEN I AND J
C IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND
C INDX = TEMPORARY INDEX FOR X
C R = PSEUDO RANDOM NUMBER FOR GENERATING IJ
C T = CENTRAL ELEMENT OF X
C
      IF (N .LE. 0) RETURN
C
C INITIALIZE IND, M, I, J, AND R
C
      DO 1 I = 1,N
    1 IND(I) = I
      M = 1
      I = 1
      J = N
      R = .375
C
C TOP OF LOOP
C
    2 IF (I .GE. J) GO TO 10
      IF (R .GT. .5898437) GO TO 3
      R = R + .0390625
      GO TO 4
    3 R = R - .21875
C
C INITIALIZE K
C
    4 K = I
C
C SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T
C
      IJ = I + IFIX(RE AL(R*FLOAT(J-I)))
      IT = IND(IJ)
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 5
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
C
C INITIALIZE L
C
    5 L = J
C
C IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T,
C INTERCHANGE IT WITH T
C
      INDX = IND(J)
      IF (X(INDX) .GE. T) GO TO 7
      IND(IJ) = INDX
      IND(J) = IT
      IT = INDX
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 7
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
      GO TO 7
C
C INTERCHANGE ELEMENTS K AND L
C
    6 ITT = IND(L)
      IND(L) = IND(K)
      IND(K) = ITT
C
C FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS
C NOT LARGER THAN T
C
    7 L = L - 1
      INDX = IND(L)
      IF (X(INDX) .GT. T) GO TO 7
C
C FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS
C NOT SMALLER THAN T
C
    8 K = K + 1
      INDX = IND(K)
      IF (X(INDX) .LT. T) GO TO 8
C
C IF K .LE. L, INTERCHANGE ELEMENTS K AND L
C
      IF (K .LE. L) GO TO 6
C
C SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE
C ARRAY YET TO BE SORTED
C
      IF (L-I .LE. J-K) GO TO 9
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 11
C
    9 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 11
C
C BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY
C
   10 M = M - 1
      IF (M .EQ. 0) RETURN
      I = IL(M)
      J = IU(M)
C
   11 IF (J-I .GE. 11) GO TO 4
      IF (I .EQ. 1) GO TO 2
      I = I - 1
C
C SORT ELEMENTS I+1,...,J. NOTE THAT 1 .LE. I .LT. J AND
C J-I .LT. 11.
C
   12 I = I + 1
      IF (I .EQ. J) GO TO 10
      INDX = IND(I+1)
      T = X(INDX)
      IT = INDX
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 12
      K = I
C
   13 IND(K+1) = IND(K)
      K = K - 1
      INDX = IND(K)
      IF (T .LT. X(INDX)) GO TO 13
      IND(K+1) = IT
      GO TO 12
      END
C ../lib/sign1.f
      DOUBLEPRECISION FUNCTION SIGN1(X,Y)
      DOUBLEPRECISION X,Y
      IF (Y .LT. 0.) THEN
         SIGN1= -ABS(X)
      ELSE
         SIGN1= ABS(X)
      ENDIF
      RETURN
      END
C ../lib/cjywb.f
C23456789012345678901234567890123456789012345678901234567890123456789012
      DOUBLECOMPLEX FUNCTION CJ0(Z)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C BERECHNET DIE KOMPLEXE BESSELFUNKTION ERSTER ART DER ORDNUNG 0
C FUER EIN KOMPLEXES ARGUMENT MIT ABS(IM(Z))>8.0.
C MATHEMATISCHER HINTERGRUND SIND GLEICHUNGEN
C (ABRAMOWITZ/ STEGUN 9.2.5, 9.1.35).
C VERIFIZIERT IST DIE PROZEDUR NUR FUER ARGUMENTE Z= SQRT(-J*X).
C
      DOUBLEPRECISION PI4
      DOUBLECOMPLEX Y,XX
      DOUBLECOMPLEX CJ
      EXTERNAL CJ
C
C ****
      IF (1 .EQ. 1) THEN
         FNU= 0
         KODE= 1
         NN= 1
         CALL CBESJ(Z, FNU, KODE, NN, CYY, NZ, IERR)
         IF (IERR .NE. 0) THEN
            WRITE (0,*) ' cbesj: ierr,z',IERR,Z
            STOP
         ENDIF
         CJ0= CYY
         RETURN
      ENDIF
C ****
C WRITE (*,*) ' IN CJ0..',Z
      Y= 8.
      Z0= Z
      PI4= ATAN(1.)
      REA= Z0
      AIMA= (0.,-1.) * Z0
      IF (REA*AIMA .EQ. 0.) THEN
         CJ0= CJ(0, RE A, AIMA)
         RETURN
      ENDIF
C *****
C WRITE (*,*) Z
C CALL ErrorStop(' CJ0: ....')
C *****
      IF (REA .LT. 0.) Z0= -Z0 !! AS 9.1.35
      Z2= 8. / Z0
      Y= Z2**2
C XX= Z0-.7853981634 !! Z0-PI/4
      XX= Z0-PI4
      CJ0= SQRT(.5/(PI4*Z0))*(
     1 COS(Z0-PI4)*( 1.
     2 +Y*(-.1098628627E-2
     3 +Y*( .2734510407E-4
     4 +Y*(-.2073370639E-5
     5 +Y* .2093887211E-6))))
     6 -Z2*SIN(Z0-PI4)*(- .1562499995E-1
     7 +Y*( .1430488765E-3
     8 +Y*(-.6911147651E-5
     9 +Y*( .7621095161E-6
     1 -Y* .934945152E-7))))
     1 )
      RETURN
      END
C *************
      DOUBLECOMPLEX FUNCTION CJE(N, Z)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
      LOGICAL SGN
      IAN= ABS(N)
      SGN= ((N.LT.0) .AND. (MOD(IAN,2).NE.0)) !! ABRAMOWITZ/ STEGUN 9.1.5
      Z0= Z
      IF (DBLE(Z0) .LT. 0.) THEN !! ABRAMOWITZ/ STEGUN 9.1.35
         Z0= -Z0
         IF (MOD(IAN,2).NE.0) SGN= .NOT. SGN
      ENDIF
      FNU= ABS(N)
      KODE= 2
      NN= 1
      CALL CBESJ(Z0, FNU, KODE, NN, CYY, NZ, IERR)
      IF (IERR .NE. 0) THEN
         WRITE (0,*) Z0, FNU, KODE, NN, CYY, NZ, IERR
         WRITE (0,*) ' cbesj: ierr,z0',IERR,Z0
         STOP
      ENDIF
      IF (SGN) THEN
         CJE= -CYY
      ELSE
         CJE= CYY
      ENDIF
      RETURN
      END
C *************
      DOUBLECOMPLEX FUNCTION ZJM(N, Z)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
C BERECHNET DIE KOMPLEXE BESSELFUNKTION ERSTER ART DER ORDNUNG N JN(Z)
C DES KOMPLEXEN ARGUMENTS Z.
C ALGORITHMUS:
C REKURSION VON EINEM SCHAETZWERT J(M,Z) HERUNTER ZU J(0,Z) NACH
C GLEICHUNG (ABRAMOWITZ/ STEGUN 9.1.27).
C DIE GEFUNDENEN FUNKTIONSWERTE SIND DANN BESTIMMT BIS AUF EINEN
C GEMEINSAMEN FAKTOR.
C NORMIERUNG DER GEFUNDENEN BESSELFUNKTION MIT:
C FALLS ABS(IM(Z))<8.0:
C 1.0 = J(0,Z) + 2*( J(2,Z)+J(4,Z)+J(6,Z)+J(8,Z)..+J(2*UNENDLICH,Z) )
C SONST DURCH AUFRUF VON CJ0(Z).
C DIE PROZEDUR IST VERIFIZIERT FUER
C 0.1<= Z=RE(Z) <= 100.0
C Z= SQRT(-J*X) MIT 0.1<= X <=100.0
C UM RECHENZEIT ZU SPAREN, WERDEN DIE WERTE DER BESSELFUNKTIONEN
C MIT GLEICHEM ARGUMENT ABER KLEINERER ORDNUNG IN EIN ARRAY EINGETRAGEN.
C
      INTEGER IACC
      DOUBLEPRECISION BIGNO, BIGNI
      PARAMETER (IACC=40)
C MAKE IACC LARGER TO INCREASE ACCURACY
      PARAMETER (BIGNO=1.E20, BIGNI= 1.E-10)
C
      DOUBLEPRECISION PI
      DOUBLECOMPLEX J,JM,JP,SUM,TOX,ANS,Z0,CJ0
      INTEGER I,AN,JI,JSUM,M,IH
      LOGICAL SGN
      DOUBLEPRECISION CABS1
C
      INTEGER NJ
      DOUBLECOMPLEX ARGJN,RETJN(0:200)
      COMMON /CJNRET/ ARGJN,RETJN,NJ
C
      DOUBLECOMPLEX CJ
      EXTERNAL CJ
      DOUBLECOMPLEX ZDUM
      CABS1(ZDUM)= ABS(ZDUM+0.)
C
C WRITE (*,*) ' IN CJM..',N,Z
      AN= ABS(N)
      SGN= ((N.LT.0) .AND. (MOD(AN,2).NE.0)) !! ABRAMOWITZ/ STEGUN 9.1.5
      Z0= Z
      IF (DBLE(Z0) .LT. 0.) THEN !! ABRAMOWITZ/ STEGUN 9.1.35
         Z0= -Z0
         IF (MOD(AN,2).NE.0) SGN= .NOT. SGN
      ENDIF
C *****************
      IF (0 .EQ. 1) THEN
         FNU= ABS(N)
         KODE= 1
         NN= 1
         CALL CBESJ(Z0, FNU, KODE, NN, CYY, NZ, IERR)
         IF (IERR .NE. 0) THEN
            WRITE (0,*) Z0, FNU, KODE, NN, CYY, NZ, IERR
            WRITE (0,*) ' cbesj: ierr,z0',IERR,Z0
            STOP
         ENDIF
         IF (SGN) THEN
            ZJM= -CYY
         ELSE
            ZJM= CYY
         ENDIF
         RETURN
      ENDIF
C *****************
      IF (CABS1(Z0) .EQ. 0.) THEN
         RETJN(0)= 1.
         DO 10 I= 1, MIN(AN,200), 1
            RETJN(I)= 0.
   10 CONTINUE
         ZJM= RETJN(MIN(AN,200))
         NJ= AN
         ARGJN= Z0
         RETURN
      ENDIF
C
      IF ((CABS1(ARGJN-Z0) .LT. 1.E-7*CABS1(Z0))
     1 .AND. (AN.LE.NJ)) THEN
C FUNKTIONSWERT BEREITS BERECHNET
         IF (SGN) THEN
            ZJM= -RETJN(AN)
         ELSE
            ZJM= RETJN(AN)
         ENDIF
         RETURN
      ENDIF
      NJ= AN
      ARGJN= Z0
      REA= Z0
      AIMA= (0.,-1.) * Z0
      IF ((AN .LE. 5) .AND.
     1 ( ABS( REA*AIMA )
     2 / MAX( ABS(REA), ABS(AIMA))
     3 .LE. 1.E-8
     4 )
     5 ) THEN
C WRITE (*,*) ' CJM: AUFWAERTSREKURSION'
         RETJN(0)= CJ(0, REA, AIMA)
         RETJN(1)= CJ(1, REA, AIMA)
         DO 11 I= 1, 4, 1
            RETJN(I+1)= 2*I*RETJN(I)/Z0 - RETJN(I-1)
   11 CONTINUE
         ANS= RETJN(AN)
         NJ= 5
      ELSE
C *****
C WRITE (*,*) N,Z
C CALL ErrorStop(' CJM: ....')
C *****
C WRITE (0,*) ' N,Z:',N,Z
C WRITE (0,*) ' Z0:',Z0
C WRITE (0,*) ' CJM: Abwaertsrekursion'
         TOX= 2./Z0
C USE DOWNWARDS RECURRENCE FROM AN EVEN VALUE M HERE COMPUTED
         M= MAX(INT(ABS(Z0+0.)),MAX(AN+3,1))
         M= 2*((M+INT(SQRT(FLOAT(IACC*M)))) / 2)
         PI= 4.*ATAN(1.)
         JP= SQRT(TOX/PI) !! AS 9.2.1
         J= JP*COS(Z0-FLOAT(2*M+1)*.25*PI)
         JP= JP*COS(Z0-FLOAT(M+1)*.5*PI-.25*PI)
         JSUM= 0
C JSUM WILL ALTERNATE BETWEEN 0 AND 1;
C WHEN IT IS 1, WE ACCUMULATE IN SUM THE EVEN TERMS
         SUM= (0., 0.)
         DO 20 JI= M, 1, -1
C J(N-1,Z)= J(N,Z)*2*N/Z - J(N+1,Z)
            JM = JI *TOX*J - JP
            JP= J
            J= JM
            IF (CABS1(J) .GT. BIGNO) THEN
               J = J *BIGNI
               JP = JP *BIGNI
               SUM= SUM*BIGNI
               ANS= ANS*BIGNI
               DO 30 IH= JI+1, MIN(200,AN+3), 1
                  RETJN(IH)= BIGNI*RETJN(IH)
   30 CONTINUE
            ENDIF
            IF (JSUM .NE. 0) SUM= SUM+J
C ACCUMULATE THE SUM.
            JSUM= 1-JSUM
C CHANGE 0 TO 1 OR VICE VERSA
            IF (JI .LE. 200) RETJN(JI)= JP
C SAVE THE UNNORMALIZED ANSWER
            IF (JI .EQ. AN) ANS= JP
   20 CONTINUE
         RETJN(0)= J
         REA= Z0
         AIMA= (0.,-1.) * Z0
         IF (ABS(RE A*AIMA) .LT. 1.E-8) THEN
            J= CJ(0, RE A, AIMA) / RETJN(0)
         ELSE
            IF (ABS(AIMA) .GT. 8.) THEN
               J= CJ0(Z0) / RETJN(0)
C BERECHNUNG DES FAKTORS
            ELSE
               SUM= 2. * SUM-J
               J= 1. / SUM
            ENDIF
         ENDIF
         NJ= MIN(200,AN+3)
         CALL ZSCAL(NJ+1,J,RETJN(0),1)
         IF (N .EQ. 0) THEN
            ANS= RETJN(0)
         ELSE
            ANS= ANS*J
C AND USE IT TO NORMALIZE THE ANSWER
         ENDIF
      ENDIF
      IF (SGN) THEN
         ZJM= -ANS
      ELSE
         ZJM= ANS
      ENDIF
C WRITE (*,*) ' AUS CJM RAUS N,Z:',N,Z
      RETURN
      END
C ************************
      DOUBLECOMPLEX FUNCTION CJES(N,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
C BERECHNET DIE ABLEITUNG NACH DEM ARGUMENT
C DER KOMPLEXEN BESSELFUNKTION JN(Z).
C
      DOUBLECOMPLEX CJE
      EXTERNAL CJE
      DOUBLECOMPLEX JNM1,JNP1
C
C WRITE (*,*) ' IN CJMS..',N,Z
      JNP1= CJE(N+1, Z)
      JNM1= CJE(N-1, Z)
C CJeS= JNM1-N*JN/Z
      CJES= .5*(JNM1-JNP1)
      RETURN
      END
C ************************
      DOUBLECOMPLEX FUNCTION ZJMS(N,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
C BERECHNET DIE ABLEITUNG NACH DEM ARGUMENT
C DER KOMPLEXEN BESSELFUNKTION JN(Z).
C
      DOUBLECOMPLEX ZJM
      EXTERNAL ZJM
      DOUBLECOMPLEX JNM1,JNP1
C
C WRITE (*,*) ' IN CJMS..',N,Z
      JNP1= ZJM(N+1, Z)
      JNM1= ZJM(N-1, Z)
C ZJMS= JNM1-N*JN/Z
      ZJMS= .5*(JNM1-JNP1)
      RETURN
      END
C ***************************
      DOUBLECOMPLEX FUNCTION CY0(Z)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C BERECHNET DIE KOMPLEXE BESSELFUNKTION ZWEITER ART DER ORDNUNG 0
C FUER EIN KOMPLEXES ARGUMENT.
C ZWEI FAELLE WERDEN UNTERSCHIEDEN:
C Z= RE(Z):
C PROZEDUR IST VERIFIZIERT FUER 0.1<= Z <=100.0.
C MATHEMATISCHER HINTERGRUND IST GLEICHUNG (ABRAMOWITZ/ STEGUN 9.1.89).
C Z= SQRT(-J*X):
C PROZEDUR IST VERIFIZIERT FUER 0.1<= X <= 100.0
C ABS(IM(Z))>8.0:
C MATHEMATISCHER HINTERGRUND IST
C GLEICHUNG (ABRAMOWITZ/ STEGUN 9.2.6).
C ABS(IM(Z))<8.0:
C MATHEMATISCHER HINTERGRUND IST
C GLEICHUNG (ABRAMOWITZ/ STEGUN 9.1.89).
C
      DOUBLECOMPLEX J,SUM,ANS,ANS1,ANS2,Y,Z2,XX,RETY0,ARGY0
      INTEGER K, K2
      DOUBLEPRECISION PI
      DOUBLECOMPLEX ZJM
      EXTERNAL ZJM
      INTEGER NJ
      DOUBLECOMPLEX ARGJN,RETJN(0:200)
      COMMON /CJNRET/ ARGJN,RETJN,NJ
C
      DOUBLECOMPLEX CY
      EXTERNAL CY
C
      SAVE RETY0,ARGY0
      DOUBLEPRECISION CABS1
      DOUBLECOMPLEX ZDUM
      CABS1(ZDUM)= ABS(ZDUM)
C
C ****
      IF (1 .EQ. 1) THEN
         FNU= 0
         KODE= 1
         NN= 1
         CALL CBESY(Z, FNU, KODE, NN, CYY, NZ, CWRK, IERR)
         IF (IERR .NE. 0) THEN
            WRITE (0,*) ' cbesy: ierr,z',IERR,Z
            STOP
         ENDIF
         CY0= CYY
         RETURN
      ENDIF
C ****
C WRITE (*,*) ' IN CY0..',Z
      IF (CABS1(Z-ARGY0) .LT. 1.E-7) THEN
         CY0= RETY0
         RETURN
      ENDIF
C
      REA= Z
      AIMA= (0.,-1.) * Z
      IF (ABS(REA*AIMA) .LE. CABS1(Z)*1.E-7) THEN
         CY0= CY(0, REA, AIMA)
         RETURN
      ENDIF
C *****
C WRITE (*,*) Z
C CALL ErrorStop(' CY0: ....')
C *****
C
      PI= 4.*ATAN(1.)
      IF (ABS(AIMA) .GT. 8.) THEN
         Z2= 8. / Z
         Y= SQRT(Z2)
         XX= Z - .25 * PI
         ANS1= 1.+Y*(-.1098628627E-2+Y*(.2734510407E-4
     1 +Y*(-.2073370639E-5+Y*.2093887211E-6)))
         ANS2= -.1562499995E-1+Y*(.1430488765E-3
     1 +Y*(-.6911147651E-5+Y*(.7621095161E-6
     2 -Y*.934945152E-7)))
         ANS= SIN(XX) * ANS1 + Z * COS(XX) * ANS2
         ANS= SQRT(2. / (PI * Z)) * ANS
         ARGY0= Z
         RETY0= ANS
         CY0= ANS
      ELSE
         SUM= 0.
         K2= MIN(2*(INT(ABS(Z))/ 2)+10, 100)
         J= ZJM(2*K2, Z)
         DO 10 K= K2, 1, -1
            IF (MOD(K,2) .NE. 0) THEN
               SUM= SUM - RETJN(2*K) / FLOAT(K)
            ELSE
               SUM= SUM + RETJN(2*K) / FLOAT(K)
            ENDIF
   10 CONTINUE
         RETY0= 2./PI*(LOG(.5*Z)+.577215664901532860606512)*ZJM(0,Z)
     1 -4./PI*SUM
         ARGY0= Z
         CY0= RETY0
      ENDIF
      RETURN
      END
C **********************************************
      DOUBLECOMPLEX FUNCTION CY1(Z)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      DOUBLECOMPLEX Z
C
C BERECHNUNG MIT DER WRONSKI-DETERMINANTE
C
C A.S. 9.1.16
C
C 2/(PI*Z) = J(1,Z)*Y(0,Z)-J(0,Z)*Y(1,Z)
C
C Y(1,Z) = -(2/(PI*Z)-J(1,Z)*Y(0,Z))/J(0,Z)
C
      DOUBLECOMPLEX J1,Y0
      DOUBLECOMPLEX CY0,ZJM,CY
      EXTERNAL CY0,ZJM,CY
C
C ****
      IF (1 .EQ. 1) THEN
         FNU= 1
         KODE= 1
         NN= 1
         CALL CBESY(Z, FNU, KODE, NN, CYY, NZ, CWRK, IERR)
         IF (IERR .NE. 0) THEN
            WRITE (0,*) ' cbesy: ierr,z',IERR,Z
            STOP
         ENDIF
         CY1= CYY
         RETURN
      ENDIF
C ****
C WRITE (*,*) ' IN CY1..',Z
      REA= Z
      AIMA= (0.,-1.) * Z
      IF (ABS( REA*AIMA )
     1 .LE. 1.E-7*( ABS(REA)+ABS(AIMA))
     2 ) THEN
         CY1= CY(1, REA, AIMA)
         RETURN
      ENDIF
C *****
C WRITE (*,*) Z
C CALL ErrorStop(' CY1: ....')
C *****
      Y0= CY0(Z)
      J1= ZJM(1,Z)
      CY1= (J1 * Y0 - 1. / (2.*ATAN(1.)) / Z) / ZJM(0,Z)
      RETURN
      END
C ***********************************
      DOUBLECOMPLEX FUNCTION CYE(N,Z)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
      LOGICAL SGN
      IAN= ABS(N)
      SGN= ((N .LT. 0) .AND. (MOD(IAN,2) .NE. 0))
      Z0= Z
      IF (DBLE(Z0) .LT. 0.) THEN !! ABRAMOWITZ/ STEGUN 9.1.36
         Z0= -Z0
         IF (MOD(IAN,2) .NE. 0) SGN= .NOT. SGN
      ENDIF
      FNU= ABS(N)
      KODE= 2
      NN= 1
      CALL CBESY(Z0, FNU, KODE, NN, CYY, NZ, CWRK, IERR)
      IF (IERR .NE. 0) THEN
         WRITE (0,*) Z0, FNU, KODE, NN, CYY, NZ, CWRK, IERR
         WRITE (0,*) ' cbesy: ierr,z0',IERR,Z0
         STOP
      ENDIF
      IF (SGN) THEN
         CYE= -CYY
      ELSE
         CYE= CYY
      ENDIF
      RETURN
      END
C ***********************************
      DOUBLECOMPLEX FUNCTION ZYM(N,Z)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
C BERECHNET DIE KOMPLEXE BESSELFUNKTION FUER EIN KOMPLEXES ARGUMENT.
C
C AUFWAERTSREKURSION
C
C UM RECHENZEIT ZU SPAREN, WERDEN DIE WERTE DER BESSELFUNKTIONEN
C MIT GLEICHEM ARGUMENT ABER KLEINERER ORDNUNG IN EIN ARRAY EINGETRAGEN.
C DIE ROUTINE SOLLTE ALSO MIT FALLENDEN INDICES AUFGERUFEN WERDEN.
C
      LOGICAL SGN
      DOUBLECOMPLEX RETYN(0:200),Z0,
     1 CY0,CY1
      EXTERNAL CY0,CY1
      INTEGER AN,I,ANP3
      INTEGER ARGYN,NY
      SAVE ARGYN,NY,RETYN
      DOUBLEPRECISION CABS1
      DOUBLECOMPLEX ZDUM
      CABS1(ZDUM)= ABS(ZDUM)
C
C WRITE (*,*) ' IN CYM..',N,Z
      AN= ABS(N)
      SGN= ((N .LT. 0) .AND. (MOD(AN,2) .NE. 0))
      Z0= Z
      IF (DBLE(Z0) .LT. 0.) THEN !! ABRAMOWITZ/ STEGUN 9.1.36
         Z0= -Z0
         IF (MOD(AN,2) .NE. 0) SGN= .NOT. SGN
      ENDIF
C **************
      IF (0 .EQ. 1) THEN
         FNU= ABS(N)
         KODE= 1
         NN= 1
         CALL CBESY(Z0, FNU, KODE, NN, CYY, NZ, CWRK, IERR)
         IF (IERR .NE. 0) THEN
            WRITE (0,*) Z0, FNU, KODE, NN, CYY, NZ, CWRK, IERR
            WRITE (0,*) ' cbesy: ierr,z0',IERR,Z0
            STOP
         ENDIF
         IF (SGN) THEN
            ZYM= -CYY
         ELSE
            ZYM= CYY
         ENDIF
         RETURN
      ENDIF
C ***********
      IF (AN .GT. 200) CALL ErrorStop(' CYM: ABS(N) .GT. 200')
      ANP3= MIN(AN+3,200)
      IF ((CABS1(ARGYN-Z0) .LT. 1.E-7*CABS1(Z0)) .AND. (AN.LE.NY)) THEN
         IF (SGN) THEN
            ZYM= -RETYN(AN)
         ELSE
            ZYM= RETYN(AN)
         ENDIF
         RETURN
      ENDIF
      RETYN(0)= CY0(Z0)
      RETYN(1)= CY1(Z0)
      DO 10 I= 1, ANP3-1, 1
         RETYN(I+1)= RETYN(I)*(I+I)/Z0 - RETYN(I-1)
   10 CONTINUE
      ARGYN= Z0
      NY= ANP3
      IF (SGN) THEN
         ZYM= -RETYN(AN)
      ELSE
         ZYM= RETYN(AN)
      ENDIF
      RETURN
      END
C *************************************
      DOUBLECOMPLEX FUNCTION CYES(N,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
      DOUBLECOMPLEX CYE,YN
      EXTERNAL CYE
C
      YN= N * CYE(N, Z) / Z
      CYES= CYE(N-1,Z) - YN
      RETURN
      END
C *************************************
      DOUBLECOMPLEX FUNCTION ZYMS(N,Z)
      INTEGER N
      DOUBLECOMPLEX Z
C
      DOUBLECOMPLEX ZYM,YN
      EXTERNAL ZYM
C
C WRITE (*,*) ' IN CYMS..',N,Z
      YN= N * ZYM(N, Z) / Z
      ZYMS= ZYM(N-1,Z) - YN
      RETURN
      END
C ../lib/jnue.f
C23456789012345678901234567890123456789012345678901234567890123456789012
C
C Diese Subroutines sind von Warner Bruns im Maerz '93 dahingehend
C veraendert worden, dass keine Ausdruecke
C z= cmplx(x, 0.0e0)
C vorkommen
C
C Das war noetig, um den Quelltext durch den cpp auf double precision
C umstellen zu koennen.
C (xlf mag keine Ausdruecke DCMPLX(x,0.0e0) )
C
C Weiterhin ist i1mach, r1mach und d1mach veraendert worden.
C speziell d1mach und r1mach beduerfen noch der Verbesserung.
C
C ************************
      SUBROUTINE CBESH(Z, FNU, KODE, M, N, CY, NZ, IERR)
C***BEGIN PROLOGUE CBESH
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT,
C BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A DOUBLECOMPLEX ARGUMENT
C***DESCRIPTION
C
C ON KODE=1, CBESH COMPUTES AN N MEMBER SEQUENCE OF DOUBLECOMPLEX
C HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1
C OR 2, DOUBLEPRECISION, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND DOUBLECOMPLEX
C Z.NE.DCMPLX(0.0E0,0.0E0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI.
C ON KODE=2, CBESH COMPUTES THE SCALED HANKEL FUNCTIONS
C
C CY(I)=H(M,FNU+J-1,Z)*EXP(-MM*Z*I) MM=3-2M, I**2=-1.
C
C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER
C AND LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN
C THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1).
C
C INPUT
C Z - Z=DCMPLX(X,Y), Z.NE.DCMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0E0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(J)=H(M,FNU+J-1,Z), J=1,...,N
C = 2 RETURNS
C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))
C J=1,...,N , I**2=-1
C M - KIND OF HANKEL FUNCTION, M=1 OR 2
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C
C OUTPUT
C CY - A DOUBLECOMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN
C VALUES FOR THE SEQUENCE
C CY(J)=H(M,FNU+J-1,Z) OR
C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N
C DEPENDING ON KODE, I**2=-1.
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO
C DUE TO UNDERFLOW, CY(J)=DCMPLX(0.0,0.0)
C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR
C Y.LT.0.0 AND M=2. FOR THE COMPLEMENTARY
C HALF PLANES, NZ STATES ONLY THE NUMBER
C OF UNDERFLOWS.
C IERR -ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, FNU+N-1 TOO
C LARGE OR ZABS(Z) TOO SMALL OR BOTH
C IERR=3, ZABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, ZABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE RELATION
C
C H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP))
C MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1
C
C FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE
C RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED
C TO THE LEFT HALF PLANE BY THE RELATION
C
C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
C
C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
C
C EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z
C PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL
C GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING
C BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE
C WHOLE Z PLANE FOR Z TO INFINITY.
C
C FOR NEGATIVE ORDERS,THE FORMULAE
C
C H(1,-FNU,Z) = H(1,FNU,Z)*ZEXP( PI*FNU*I)
C H(2,-FNU,Z) = H(2,FNU,Z)*ZEXP(-PI*FNU*I)
C I**2=-1
C
C CAN BE USED.
C
C IN MOST DOUBLECOMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
C IERR=3 IS TRIGGERED WHERE UR=R1MACH(4)=UNIT ROUNDOFF. ALSO
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A DOUBLECOMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(ZABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C ZABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C BECAUSE, IN DOUBLECOMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C OR -PI/2+P.
C
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED CACON,CBKNU,CBUNK,CUOIK,I1MACH,R1MACH
C***END PROLOGUE CBESH
C
      DOUBLECOMPLEX
     1 CY, Z, ZN, ZT
      DOUBLEPRECISION
     1 AA, ALIM, ALN, ARG, AZ, CPN, DIG, ELIM, FMM, FN, FNU, FNUL,
     * HPI, RHPI, RL, R1M5, SGN, SPN, TOL, UFL, XN, XX, YN, YY, R1MACH,
     * BB
      INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M,
     * MM, MR, N, NN, NUF, NW, NZ, I1MACH
      DIMENSION CY(*)
C
      DATA HPI /1.57079632679489662E0/
C
C***FIRST EXECUTABLE STATEMENT CBESH
      NZ=0
      XX = DBLE(Z)
      YY = DIMAG(Z)
      IERR = 0
      IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1
      IF (FNU.LT.0.0E0) IERR=1
      IF (M.LT.1 .OR. M.GT.2) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      NN = N
C-----------------------------------------------------------------------
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
C-----------------------------------------------------------------------
      TOL = DMAX1(R1MACH(4),DBLE(1.0E-18))
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN0(IABS(K1),IABS(K2))
      ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*FLOAT(K1)
      DIG = DMIN1(AA,DBLE(18.0E0))
      AA = AA*2.303E0
      ALIM = ELIM + DMAX1(-AA,DBLE(-41.45E0))
      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
      RL = 1.2E0*DIG + 3.0E0
      FN = FNU + FLOAT(NN-1)
      MM = 3 - M - M
      FMM = FLOAT(MM)
C ZN = Z*DCMPLX(0.0E0,-FMM)
      ZN= Z*(0.,-1.)*FMM
      XN = DBLE(ZN)
      YN = DIMAG(ZN)
      AZ = ZABS(Z)
C-----------------------------------------------------------------------
C TEST FOR RANGE
C-----------------------------------------------------------------------
      AA = 0.5E0/TOL
      BB=FLOAT(I1MACH(9))*0.5E0
      AA=DMIN1(AA,BB)
      IF(AZ.GT.AA) GO TO 240
      IF(FN.GT.AA) GO TO 240
      AA=SQRT(AA)
      IF(AZ.GT.AA) IERR=3
      IF(FN.GT.AA) IERR=3
C-----------------------------------------------------------------------
C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
C-----------------------------------------------------------------------
      UFL = EXP(-ELIM)
      IF (AZ.LT.UFL) GO TO 220
      IF (FNU.GT.FNUL) GO TO 90
      IF (FN.LE.1.0E0) GO TO 70
      IF (FN.GT.2.0E0) GO TO 60
      IF (AZ.GT.TOL) GO TO 70
      ARG = 0.5E0*AZ
      ALN = -FN*DLOG(ARG)
      IF (ALN.GT.ELIM) GO TO 220
      GO TO 70
   60 CONTINUE
      CALL CUOIK(ZN, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM)
      IF (NUF.LT.0) GO TO 220
      NZ = NZ + NUF
      NN = NN - NUF
C-----------------------------------------------------------------------
C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
C-----------------------------------------------------------------------
      IF (NN.EQ.0) GO TO 130
   70 CONTINUE
      IF ((XN.LT.0.0E0) .OR. (XN.EQ.0.0E0 .AND. YN.LT.0.0E0 .AND.
     * M.EQ.2)) GO TO 80
C-----------------------------------------------------------------------
C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR.
C YN.GE.0. .OR. M=1)
C-----------------------------------------------------------------------
      CALL CBKNU(ZN, FNU, KODE, NN, CY, NZ, TOL, ELIM, ALIM)
      GO TO 110
C-----------------------------------------------------------------------
C LEFT HALF PLANE COMPUTATION
C-----------------------------------------------------------------------
   80 CONTINUE
      MR = -MM
      CALL CACON(ZN, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM,
     * ALIM)
      IF (NW.LT.0) GO TO 230
      NZ=NW
      GO TO 110
   90 CONTINUE
C-----------------------------------------------------------------------
C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
C-----------------------------------------------------------------------
      MR = 0
      IF ((XN.GE.0.0E0) .AND. (XN.NE.0.0E0 .OR. YN.GE.0.0E0 .OR.
     * M.NE.2)) GO TO 100
      MR = -MM
      IF (XN.EQ.0.0E0 .AND. YN.LT.0.0E0) ZN = -ZN
  100 CONTINUE
      CALL CBUNK(ZN, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 230
      NZ = NZ + NW
  110 CONTINUE
C-----------------------------------------------------------------------
C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT)
C
C ZT=EXP(-FMM*HPI*I) = DCMPLX(0.0,-FMM), FMM=3-2*M, M=1,2
C-----------------------------------------------------------------------
      SGN = SIGN(HPI,-FMM)
C-----------------------------------------------------------------------
C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
C WHEN FNU IS LARGE
C-----------------------------------------------------------------------
      INU = INT(FNU)
      INUH = INU/2
      IR = INU - 2*INUH
      ARG = (FNU-FLOAT(INU-IR))*SGN
      RHPI = 1.0E0/SGN
      CPN = RHPI*COS(ARG)
      SPN = RHPI*SIN(ARG)
      ZN = DCMPLX(-SPN,CPN)
      IF (MOD(INUH,2).EQ.1) ZN = -ZN
C ZT = DCMPLX(0.0E0,-FMM)
      ZT= (0.,-1.)*FMM
      DO 120 I=1,NN
        CY(I) = CY(I)*ZN
        ZN = ZN*ZT
  120 CONTINUE
      RETURN
  130 CONTINUE
      IF (XN.LT.0.0E0) GO TO 220
      RETURN
  220 CONTINUE
      IERR=2
      NZ=0
      RETURN
  230 CONTINUE
      IF(NW.EQ.(-1)) GO TO 220
      NZ=0
      IERR=5
      RETURN
  240 CONTINUE
      NZ=0
      IERR=4
      RETURN
      END
C ******************
      SUBROUTINE CBESI(Z, FNU, KODE, N, CY, NZ, IERR)
C***BEGIN PROLOGUE CBESI
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS I-BESSEL FUNCTION,DOUBLECOMPLEX BESSEL FUNCTION,
C MODIFIED BESSEL FUNCTION OF THE FIRST KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE I-BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C***DESCRIPTION
C
C ON KODE=1, CBESI COMPUTES AN N MEMBER SEQUENCE OF DOUBLECOMPLEX
C BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR DOUBLEPRECISION, NONNEGATIVE
C ORDERS FNU+J-1, J=1,...,N AND DOUBLECOMPLEX Z IN THE CUT PLANE
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESI RETURNS THE SCALED
C FUNCTIONS
C
C CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z) J = 1,...,N , X=DBLE(Z)
C
C WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND
C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND
C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL
C FUNCTIONS (REF.1)
C
C INPUT
C Z - Z=DCMPLX(X,Y), -PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0E0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(J)=I(FNU+J-1,Z), J=1,...,N
C = 2 RETURNS
C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C
C OUTPUT
C CY - A DOUBLECOMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN
C VALUES FOR THE SEQUENCE
C CY(J)=I(FNU+J-1,Z) OR
C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)) J=1,...,N
C DEPENDING ON KODE, X=DBLE(Z)
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO
C DUE TO UNDERFLOW, CY(J)=DCMPLX(0.0,0.0),
C J = N-NZ+1,...,N
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, DBLE(Z) TOO
C LARGE ON KODE=1
C IERR=3, ZABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, ZABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR
C SMALL ZABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE ZABS(Z),
C THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A
C NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE
C UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z)
C FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE
C SEQUENCES OR REDUCE ORDERS WHEN NECESSARY.
C
C THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND
C CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA
C
C I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z) DBLE(Z).GT.0.0
C M = +I OR -I, I**2=-1
C
C FOR NEGATIVE ORDERS,THE FORMULA
C
C I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z)
C
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
C INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE
C NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
C K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
C LARGE MEANS FNU.GT.ZABS(Z).
C
C IN MOST DOUBLECOMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
C IERR=3 IS TRIGGERED WHERE UR=R1MACH(4)=UNIT ROUNDOFF. ALSO
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A DOUBLECOMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(ZABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C ZABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C BECAUSE, IN DOUBLECOMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C OR -PI/2+P.
C
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED CBINU,I1MACH,R1MACH
C***END PROLOGUE CBESI
      DOUBLECOMPLEX
     1 CONE, CSGN, CY, Z, ZN
      DOUBLEPRECISION
     1 AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, S1, S2,
     * TOL, XX, YY, R1MACH, AZ, FN, BB
      INTEGER I, IERR, INU, K, KODE, K1, K2, N, NN, NZ, I1MACH
      DIMENSION CY(1)
      DATA PI /3.14159265358979324E0/
      DATA CONE / (1.0E0,0.0E0) /
C
C***FIRST EXECUTABLE STATEMENT CBESI
      IERR = 0
      NZ=0
      IF (FNU.LT.0.0E0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      XX = DBLE(Z)
      YY = DIMAG(Z)
C-----------------------------------------------------------------------
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
C-----------------------------------------------------------------------
      TOL = DMAX1(R1MACH(4),DBLE(1.0E-18))
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN0(IABS(K1),IABS(K2))
      ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*FLOAT(K1)
      DIG = DMIN1(AA,DBLE(18.0E0))
      AA = AA*2.303E0
      ALIM = ELIM + DMAX1(-AA,DBLE(-41.45E0))
      RL = 1.2E0*DIG + 3.0E0
      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
      AZ = ZABS(Z)
C-----------------------------------------------------------------------
C TEST FOR RANGE
C-----------------------------------------------------------------------
      AA = 0.5E0/TOL
      BB=FLOAT(I1MACH(9))*0.5E0
      AA=DMIN1(AA,BB)
      IF(AZ.GT.AA) GO TO 140
      FN=FNU+FLOAT(N-1)
      IF(FN.GT.AA) GO TO 140
      AA=SQRT(AA)
      IF(AZ.GT.AA) IERR=3
      IF(FN.GT.AA) IERR=3
      ZN = Z
      CSGN = CONE
      IF (XX.GE.0.0E0) GO TO 40
      ZN = -Z
C-----------------------------------------------------------------------
C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
C WHEN FNU IS LARGE
C-----------------------------------------------------------------------
      INU = INT(FNU)
      ARG = (FNU-FLOAT(INU))*PI
      IF (YY.LT.0.0E0) ARG = -ARG
      S1 = COS(ARG)
      S2 = SIN(ARG)
      CSGN = DCMPLX(S1,S2)
      IF (MOD(INU,2).EQ.1) CSGN = -CSGN
   40 CONTINUE
      CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
      IF (NZ.LT.0) GO TO 120
      IF (XX.GE.0.0E0) RETURN
C-----------------------------------------------------------------------
C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE
C-----------------------------------------------------------------------
      NN = N - NZ
      IF (NN.EQ.0) RETURN
      DO 50 I=1,NN
        CY(I) = CY(I)*CSGN
        CSGN = -CSGN
   50 CONTINUE
      RETURN
  120 CONTINUE
      IF(NZ.EQ.(-2)) GO TO 130
      NZ = 0
      IERR=2
      RETURN
  130 CONTINUE
      NZ=0
      IERR=5
      RETURN
  140 CONTINUE
      NZ=0
      IERR=4
      RETURN
      END
C **************
      SUBROUTINE CBESJ(Z, FNU, KODE, N, CY, NZ, IERR)
C***BEGIN PROLOGUE CBESJ
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF DOUBLECOMPLEX ARGUMENT,
C BESSEL FUNCTION OF FIRST KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A DOUBLECOMPLEX ARGUMENT
C***DESCRIPTION
C
C ON KODE=1, CBESJ COMPUTES AN N MEMBER SEQUENCE OF DOUBLECOMPLEX
C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR DOUBLEPRECISION, NONNEGATIVE
C ORDERS FNU+I-1, I=1,...,N AND DOUBLECOMPLEX Z IN THE CUT PLANE
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED
C FUNCTIONS
C
C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=DIMAG(Z)
C
C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
C (REF. 1).
C
C INPUT
C Z - Z=DCMPLX(X,Y), -PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0E0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(I)=J(FNU+I-1,Z), I=1,...,N
C = 2 RETURNS
C CY(I)=J(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C
C OUTPUT
C CY - A DOUBLECOMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN
C VALUES FOR THE SEQUENCE
C CY(I)=J(FNU+I-1,Z) OR
C CY(I)=J(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N
C DEPENDING ON KODE, Y=DIMAG(Z).
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO
C DUE TO UNDERFLOW, CY(I)=DCMPLX(0.0,0.0),
C I = N-NZ+1,...,N
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, DIMAG(Z)
C TOO LARGE ON KODE=1
C IERR=3, ZABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, ZABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE FORMULA
C
C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) DIMAG(Z).GE.0.0
C
C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) DIMAG(Z).LT.0.0
C
C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION.
C
C FOR NEGATIVE ORDERS,THE FORMULA
C
C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU)
C
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A
C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
C Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
C LARGE MEANS FNU.GT.ZABS(Z).
C
C IN MOST DOUBLECOMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
C IERR=3 IS TRIGGERED WHERE UR=R1MACH(4)=UNIT ROUNDOFF. ALSO
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A DOUBLECOMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(ZABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C ZABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C BECAUSE, IN DOUBLECOMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C OR -PI/2+P.
C
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED CBINU,I1MACH,R1MACH
C***END PROLOGUE CBESJ
C
      DOUBLECOMPLEX
     1 CI, CSGN, CY, Z, ZN
      DOUBLEPRECISION
     1 AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, HPI, RL, R1, R1M5, R2,
     * TOL, YY, R1MACH, AZ, FN, BB
      INTEGER I, IERR, INU, INUH, IR, KODE, K1, K2, N, NL, NZ, I1MACH, K
      DIMENSION CY(1)
      DATA HPI /1.57079632679489662E0/
C
C***FIRST EXECUTABLE STATEMENT CBESJ
      IERR = 0
      NZ=0
      IF (FNU.LT.0.0E0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
C-----------------------------------------------------------------------
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
C-----------------------------------------------------------------------
      TOL = DMAX1(R1MACH(4),DBLE(1.0E-18))
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN0(IABS(K1),IABS(K2))
      ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*FLOAT(K1)
      DIG = DMIN1(AA,DBLE(18.0E0))
      AA = AA*2.303E0
      ALIM = ELIM + DMAX1(-AA,DBLE(-41.45E0))
      RL = 1.2E0*DIG + 3.0E0
      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
C CI = DCMPLX(0.0E0,1.0E0)
      CI= (0.,1.)
      YY = DIMAG(Z)
      AZ = ZABS(Z)
C-----------------------------------------------------------------------
C TEST FOR RANGE
C-----------------------------------------------------------------------
      AA = 0.5E0/TOL
      BB=FLOAT(I1MACH(9))*0.5E0
      AA=DMIN1(AA,BB)
      FN=FNU+FLOAT(N-1)
      IF(AZ.GT.AA) GO TO 140
      IF(FN.GT.AA) GO TO 140
      AA=SQRT(AA)
      IF(AZ.GT.AA) IERR=3
      IF(FN.GT.AA) IERR=3
C-----------------------------------------------------------------------
C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
C WHEN FNU IS LARGE
C-----------------------------------------------------------------------
      INU = INT(FNU)
      INUH = INU/2
      IR = INU - 2*INUH
      ARG = (FNU-FLOAT(INU-IR))*HPI
      R1 = COS(ARG)
      R2 = SIN(ARG)
      CSGN = DCMPLX(R1,R2)
      IF (MOD(INUH,2).EQ.1) CSGN = -CSGN
C-----------------------------------------------------------------------
C ZN IS IN THE RIGHT HALF PLANE
C-----------------------------------------------------------------------
      ZN = -Z*CI
      IF (YY.GE.0.0E0) GO TO 40
      ZN = -ZN
      CSGN = DCONJG(CSGN)
      CI = DCONJG(CI)
   40 CONTINUE
      CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
      IF (NZ.LT.0) GO TO 120
      NL = N - NZ
      IF (NL.EQ.0) RETURN
      DO 50 I=1,NL
        CY(I) = CY(I)*CSGN
        CSGN = CSGN*CI
   50 CONTINUE
      RETURN
  120 CONTINUE
      IF(NZ.EQ.(-2)) GO TO 130
      NZ = 0
      IERR = 2
      RETURN
  130 CONTINUE
C write (*,*) ' CBESJ: NZ:',NZ
      NZ=0
      IERR=5
      RETURN
  140 CONTINUE
      NZ=0
      IERR=4
      RETURN
      END
C *****************************************
      SUBROUTINE CBESK(Z, FNU, KODE, N, CY, NZ, IERR)
C***BEGIN PROLOGUE CBESK
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS K-BESSEL FUNCTION,DOUBLECOMPLEX BESSEL FUNCTION,
C MODIFIED BESSEL FUNCTION OF THE SECOND KIND,
C BESSEL FUNCTION OF THE THIRD KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE K-BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C***DESCRIPTION
C
C ON KODE=1, CBESK COMPUTES AN N MEMBER SEQUENCE OF DOUBLECOMPLEX
C BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR DOUBLEPRECISION, NONNEGATIVE
C ORDERS FNU+J-1, J=1,...,N AND DOUBLECOMPLEX Z.NE.DCMPLX(0.0,0.0)
C IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESK
C RETURNS THE SCALED K FUNCTIONS,
C
C CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N,
C
C WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND
C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND
C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL
C FUNCTIONS (REF. 1).
C
C INPUT
C Z - Z=DCMPLX(X,Y),Z.NE.DCMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0E0
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(I)=K(FNU+I-1,Z), I=1,...,N
C = 2 RETURNS
C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
C
C OUTPUT
C CY - A DOUBLECOMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN
C VALUES FOR THE SEQUENCE
C CY(I)=K(FNU+I-1,Z), I=1,...,N OR
C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
C DEPENDING ON KODE
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW.
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO
C DUE TO UNDERFLOW, CY(I)=DCMPLX(0.0,0.0),
C I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0
C NZ STATES ONLY THE NUMBER OF UNDERFLOWS
C IN THE SEQUENCE.
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, FNU+N-1 IS
C TOO LARGE OR ZABS(Z) IS TOO SMALL OR BOTH
C IERR=3, ZABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, ZABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS
C DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD
C RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT
C HALF PLANE BY THE RELATION
C
C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
C
C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
C
C FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED
C BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS.
C
C FOR NEGATIVE ORDERS, THE FORMULA
C
C K(-FNU,Z) = K(FNU,Z)
C
C CAN BE USED.
C
C CBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS
C AVAILABLE.
C
C IN MOST DOUBLECOMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
C IERR=3 IS TRIGGERED WHERE UR=R1MACH(4)=UNIT ROUNDOFF. ALSO
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A DOUBLECOMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(ZABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C ZABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C BECAUSE, IN DOUBLECOMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C OR -PI/2+P.
C
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983.
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED CACON,CBKNU,CBUNK,CUOIK,I1MACH,R1MACH
C***END PROLOGUE CBESK
C
      DOUBLECOMPLEX
     1 CY, Z
      DOUBLEPRECISION
     1 AA, ALIM, ALN, ARG, AZ, DIG, ELIM, FN, FNU, FNUL, RL, R1M5,
     * TOL, UFL, XX, YY, R1MACH, BB
      INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH
      DIMENSION CY(1)
C***FIRST EXECUTABLE STATEMENT CBESK
      IERR = 0
      NZ=0
      XX = DBLE(Z)
      YY = DIMAG(Z)
      IF (YY.EQ.0.0E0 .AND. XX.EQ.0.0E0) IERR=1
      IF (FNU.LT.0.0E0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      NN = N
C-----------------------------------------------------------------------
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
C-----------------------------------------------------------------------
      TOL = DMAX1(R1MACH(4),DBLE(1.0E-18))
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN0(IABS(K1),IABS(K2))
      ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*FLOAT(K1)
      DIG = DMIN1(AA,DBLE(18.0E0))
      AA = AA*2.303E0
      ALIM = ELIM + DMAX1(-AA,DBLE(-41.45E0))
      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
      RL = 1.2E0*DIG + 3.0E0
      AZ = ZABS(Z)
      FN = FNU + FLOAT(NN-1)
C-----------------------------------------------------------------------
C TEST FOR RANGE
C-----------------------------------------------------------------------
      AA = 0.5E0/TOL
      BB=FLOAT(I1MACH(9))*0.5E0
      AA=DMIN1(AA,BB)
      IF(AZ.GT.AA) GO TO 210
      IF(FN.GT.AA) GO TO 210
      AA=SQRT(AA)
      IF(AZ.GT.AA) IERR=3
      IF(FN.GT.AA) IERR=3
C-----------------------------------------------------------------------
C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
C-----------------------------------------------------------------------
      UFL = EXP(-ELIM)
      IF (AZ.LT.UFL) GO TO 180
      IF (FNU.GT.FNUL) GO TO 80
      IF (FN.LE.1.0E0) GO TO 60
      IF (FN.GT.2.0E0) GO TO 50
      IF (AZ.GT.TOL) GO TO 60
      ARG = 0.5E0*AZ
      ALN = -FN*DLOG(ARG)
      IF (ALN.GT.ELIM) GO TO 180
      GO TO 60
   50 CONTINUE
      CALL CUOIK(Z, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM)
      IF (NUF.LT.0) GO TO 180
      NZ = NZ + NUF
      NN = NN - NUF
C-----------------------------------------------------------------------
C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
C-----------------------------------------------------------------------
      IF (NN.EQ.0) GO TO 100
   60 CONTINUE
      IF (XX.LT.0.0E0) GO TO 70
C-----------------------------------------------------------------------
C RIGHT HALF PLANE COMPUTATION, DBLE(Z).GE.0.
C-----------------------------------------------------------------------
      CALL CBKNU(Z, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 200
      NZ=NW
      RETURN
C-----------------------------------------------------------------------
C LEFT HALF PLANE COMPUTATION
C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2.
C-----------------------------------------------------------------------
   70 CONTINUE
      IF (NZ.NE.0) GO TO 180
      MR = 1
      IF (YY.LT.0.0E0) MR = -1
      CALL CACON(Z, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM,
     * ALIM)
      IF (NW.LT.0) GO TO 200
      NZ=NW
      RETURN
C-----------------------------------------------------------------------
C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
C-----------------------------------------------------------------------
   80 CONTINUE
      MR = 0
      IF (XX.GE.0.0E0) GO TO 90
      MR = 1
      IF (YY.LT.0.0E0) MR = -1
   90 CONTINUE
      CALL CBUNK(Z, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 200
      NZ = NZ + NW
      RETURN
  100 CONTINUE
      IF (XX.LT.0.0E0) GO TO 180
      RETURN
  180 CONTINUE
      NZ = 0
      IERR=2
      RETURN
  200 CONTINUE
      IF(NW.EQ.(-1)) GO TO 180
      NZ=0
      IERR=5
      RETURN
  210 CONTINUE
      NZ=0
      IERR=4
      RETURN
      END
C ***************
      SUBROUTINE CBESY(Z, FNU, KODE, N, CY, NZ, CWRK, IERR)
C***BEGIN PROLOGUE CBESY
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF DOUBLECOMPLEX ARGUMENT,
C BESSEL FUNCTION OF SECOND KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A DOUBLECOMPLEX ARGUMENT
C***DESCRIPTION
C
C ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF DOUBLECOMPLEX
C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR DOUBLEPRECISION, NONNEGATIVE
C ORDERS FNU+I-1, I=1,...,N AND DOUBLECOMPLEX Z IN THE CUT PLANE
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED
C FUNCTIONS
C
C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=DIMAG(Z)
C
C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
C (REF. 1).
C
C INPUT
C Z - Z=DCMPLX(X,Y), Z.NE.DCMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0E0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(I)=Y(FNU+I-1,Z), I=1,...,N
C = 2 RETURNS
C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N
C WHERE Y=DIMAG(Z)
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C CWRK - A DOUBLECOMPLEX WORK VECTOR OF DIMENSION AT LEAST N
C
C OUTPUT
C CY - A DOUBLECOMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN
C VALUES FOR THE SEQUENCE
C CY(I)=Y(FNU+I-1,Z) OR
C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N
C DEPENDING ON KODE.
C NZ - NZ=0 , A NORMAL RETURN
C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO
C UNDERFLOW (GENERALLY ON KODE=2)
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, FNU+N-1 IS
C TOO LARGE OR ZABS(Z) IS TOO SMALL OR BOTH
C IERR=3, ZABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFICANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, ZABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE FORMULA
C
C Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I
C
C WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z)
C AND H(2,FNU,Z) ARE CALCULATED IN CBESH.
C
C FOR NEGATIVE ORDERS,THE FORMULA
C
C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU)
C
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD
C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE
C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)*
C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS
C NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A
C LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM
C CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS,
C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF
C ODD INTEGER. HERE, LARGE MEANS FNU.GT.ZABS(Z).
C
C IN MOST DOUBLECOMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
C IERR=3 IS TRIGGERED WHERE UR=R1MACH(4)=UNIT ROUNDOFF. ALSO
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A DOUBLECOMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(ZABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C ZABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C BECAUSE, IN DOUBLECOMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C OR -PI/2+P.
C
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED CBESH,I1MACH,R1MACH
C***END PROLOGUE CBESY
C
      DOUBLECOMPLEX
     1 CWRK, CY, C1, C2, EX, HCI, Z
      DOUBLEPRECISION
     1 ELIM, EY, FNU, R1, R2, TAY, XX, YY, R1MACH
      INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH
      DIMENSION CY(*), CWRK(*)
C***FIRST EXECUTABLE STATEMENT CBESY
      XX = DBLE(Z)
      YY = DIMAG(Z)
      IERR = 0
      NZ=0
      IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1
      IF (FNU.LT.0.0E0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
C HCI = DCMPLX(0.0E0,0.5E0)
      HCI= (0.,.5)
      CALL CBESH(Z, FNU, KODE, 1, N, CY, NZ1, IERR)
      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
      CALL CBESH(Z, FNU, KODE, 2, N, CWRK, NZ2, IERR)
      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
      NZ = MIN0(NZ1,NZ2)
      IF (KODE.EQ.2) GO TO 60
      DO 50 I=1,N
        CY(I) = HCI*(CWRK(I)-CY(I))
   50 CONTINUE
      RETURN
   60 CONTINUE
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      K = MIN0(IABS(K1),IABS(K2))
C-----------------------------------------------------------------------
C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
C-----------------------------------------------------------------------
      ELIM = 2.303E0*(FLOAT(K)*R1MACH(5)-3.0E0)
      R1 = COS(XX)
      R2 = SIN(XX)
      EX = DCMPLX(R1,R2)
      EY = 0.0E0
      TAY = ABS(YY+YY)
      IF (TAY.LT.ELIM) EY = EXP(-TAY)
      IF (YY.LT.0.0E0) GO TO 90
C C1 = EX*DCMPLX(EY,0.0E0)
      C1= EX*EY
      C2 = DCONJG(EX)
   70 CONTINUE
      NZ = 0
      DO 80 I=1,N
        CY(I) = HCI*(C2*CWRK(I)-C1*CY(I))
C IF (CY(I).EQ.DCMPLX(0.0E0,0.0E0) .AND. EY.EQ.0.0E0) NZ = NZ + 1
        IF (CY(I).EQ.(0.,0.) .AND. EY.EQ.0.0E0) NZ = NZ + 1
   80 CONTINUE
      RETURN
   90 CONTINUE
      C1 = EX
C C2 = DCONJG(EX)*DCMPLX(EY,0.0E0)
      C2= DCONJG(EX)*EY
      GO TO 70
  170 CONTINUE
      NZ = 0
      RETURN
      END
C ***************
      SUBROUTINE CAIRY(Z, ID, KODE, AI, NZ, IERR)
C***BEGIN PROLOGUE CAIRY
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR DOUBLECOMPLEX Z
C***DESCRIPTION
C
C ON KODE=1, CAIRY COMPUTES THE DOUBLECOMPLEX AIRY FUNCTION AI(Z) OR
C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
C KODE=2, A SCALING OPTION ZEXP(ZTA)*AI(Z) OR ZEXP(ZTA)*
C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN
C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN
C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*ZSQRT(Z)
C
C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN
C THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED
C FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE DOUBLEPRECISION AXIS.
C DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
C MATHEMATICAL FUNCTIONS (REF. 1).
C
C INPUT
C Z - Z=DCMPLX(X,Y)
C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C AI=AI(Z) ON ID=0 OR
C AI=DAI(Z)/DZ ON ID=1
C = 2 RETURNS
C AI=ZEXP(ZTA)*AI(Z) ON ID=0 OR
C AI=ZEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE
C ZTA=(2/3)*Z*ZSQRT(Z)
C
C OUTPUT
C AI - DOUBLECOMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
C KODE
C NZ - UNDERFLOW INDICATOR
C NZ= 0 , NORMAL RETURN
C NZ= 1 , AI=DCMPLX(0.0,0.0) DUE TO UNDERFLOW IN
C -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, DBLE(ZTA)
C TOO LARGE WITH KODE=1.
C IERR=3, ZABS(Z) LARGE - COMPUTATION COMPLETED
C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
C PRODUCE LESS THAN HALF OF MACHINE ACCURACY
C IERR=4, ZABS(Z) TOO LARGE - NO COMPUTATION
C COMPLETE LOSS OF ACCURACY BY ARGUMENT
C REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C
C***LONG DESCRIPTION
C
C AI AND DAI ARE COMPUTED FOR ZABS(Z).GT.1.0 FROM THE K BESSEL
C FUNCTIONS BY
C
C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA)
C C=1.0/(PI*SQRT(3.0))
C ZTA=(2/3)*Z**(3/2)
C
C WITH THE POWER SERIES FOR ZABS(Z).LE.1.0.
C
C IN MOST DOUBLECOMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
C FLAG IERR=3 IS TRIGGERED WHERE UR=R1MACH(4)=UNIT ROUNDOFF.
C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
C MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A DOUBLECOMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(ZABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C ZABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C BECAUSE, IN DOUBLECOMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C OR -PI/2+P.
C
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED CACAI,CBKNU,I1MACH,R1MACH
C***END PROLOGUE CAIRY
      DOUBLECOMPLEX
     1 AI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3
      DOUBLEPRECISION
     1 AA, AD, AK, ALIM, ATRM, AZ, AZ3, BK, CK, COEF, C1, C2, DIG,
     * DK, D1, D2, ELIM, FID, FNU, RL, R1M5, SFAC, TOL, TTH, ZI, ZR,
     * Z3I, Z3R, R1MACH, BB, ALAZ
      INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH
      DIMENSION CY(1)
      DATA TTH, C1, C2, COEF /6.66666666666666667E-01,
     * 3.55028053887817240E-01,2.58819403792806799E-01,
     * 1.83776298473930683E-01/
      DATA CONE / (1.0E0,0.0E0) /
C***FIRST EXECUTABLE STATEMENT CAIRY
      IERR = 0
      NZ=0
      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (IERR.NE.0) RETURN
      AZ = ZABS(Z)
      TOL = DMAX1(R1MACH(4),DBLE(1.0E-18))
      FID = FLOAT(ID)
      IF (AZ.GT.1.0E0) GO TO 60
C-----------------------------------------------------------------------
C POWER SERIES FOR ZABS(Z).LE.1.
C-----------------------------------------------------------------------
      S1 = CONE
      S2 = CONE
      IF (AZ.LT.TOL) GO TO 160
      AA = AZ*AZ
      IF (AA.LT.TOL/AZ) GO TO 40
      TRM1 = CONE
      TRM2 = CONE
      ATRM = 1.0E0
      Z3 = Z*Z*Z
      AZ3 = AZ*AA
      AK = 2.0E0 + FID
      BK = 3.0E0 - FID - FID
      CK = 4.0E0 - FID
      DK = 3.0E0 + FID + FID
      D1 = AK*DK
      D2 = BK*CK
      AD = DMIN1(D1,D2)
      AK = 24.0E0 + 9.0E0*FID
      BK = 30.0E0 - 9.0E0*FID
      Z3R = DBLE(Z3)
      Z3I = DIMAG(Z3)
      DO 30 K=1,25
        TRM1 = TRM1*DCMPLX(Z3R/D1,Z3I/D1)
        S1 = S1 + TRM1
        TRM2 = TRM2*DCMPLX(Z3R/D2,Z3I/D2)
        S2 = S2 + TRM2
        ATRM = ATRM*AZ3/AD
        D1 = D1 + AK
        D2 = D2 + BK
        AD = DMIN1(D1,D2)
        IF (ATRM.LT.TOL*AD) GO TO 40
        AK = AK + 18.0E0
        BK = BK + 18.0E0
   30 CONTINUE
   40 CONTINUE
      IF (ID.EQ.1) GO TO 50
C AI = S1*DCMPLX(C1,0.0E0) - Z*S2*DCMPLX(C2,0.0E0)
      AI= S1*C1 - Z*S2*C2
      IF (KODE.EQ.1) RETURN
C ZTA = Z*ZSQRT(Z)*DCMPLX(TTH,0.0E0)
      ZTA= Z*ZSQRT(Z)*TTH
      AI = AI*ZEXP(ZTA)
      RETURN
   50 CONTINUE
C AI = -S2*DCMPLX(C2,0.0E0)
      AI= -S2*C2
C IF (AZ.GT.TOL) AI = AI + Z*Z*S1*DCMPLX(C1/(1.0E0+FID),0.0E0)
      IF (AZ.GT.TOL) AI = AI + Z*Z*S1*C1/(1.+FID)
      IF (KODE.EQ.1) RETURN
C ZTA = Z*ZSQRT(Z)*DCMPLX(TTH,0.0E0)
      ZTA = Z*ZSQRT(Z)*TTH
      AI = AI*ZEXP(ZTA)
      RETURN
C-----------------------------------------------------------------------
C CASE FOR ZABS(Z).GT.1.0
C-----------------------------------------------------------------------
   60 CONTINUE
      FNU = (1.0E0+FID)/3.0E0
C-----------------------------------------------------------------------
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C-----------------------------------------------------------------------
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN0(IABS(K1),IABS(K2))
      ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*FLOAT(K1)
      DIG = DMIN1(AA,DBLE(18.0E0))
      AA = AA*2.303E0
      ALIM = ELIM + DMAX1(-AA,DBLE(-41.45E0))
      RL = 1.2E0*DIG + 3.0E0
      ALAZ=DLOG(AZ)
C-----------------------------------------------------------------------
C TEST FOR RANGE
C-----------------------------------------------------------------------
      AA=0.5E0/TOL
      BB=FLOAT(I1MACH(9))*0.5E0
      AA=DMIN1(AA,BB)
      AA=AA**TTH
      IF (AZ.GT.AA) GO TO 260
      AA=SQRT(AA)
      IF (AZ.GT.AA) IERR=3
      CSQ=ZSQRT(Z)
C ZTA=Z*CSQ*DCMPLX(TTH,0.0E0)
      ZTA=Z*CSQ*TTH
C-----------------------------------------------------------------------
C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
C-----------------------------------------------------------------------
      IFLAG = 0
      SFAC = 1.0E0
      ZI = DIMAG(Z)
      ZR = DBLE(Z)
      AK = DIMAG(ZTA)
      IF (ZR.GE.0.0E0) GO TO 70
      BK = DBLE(ZTA)
      CK = -ABS(BK)
      ZTA = DCMPLX(CK,AK)
   70 CONTINUE
      IF (ZI.NE.0.0E0) GO TO 80
      IF (ZR.GT.0.0E0) GO TO 80
C ZTA = DCMPLX(0.0E0,AK)
      ZTA= (0.,1.)*AK
   80 CONTINUE
      AA = DBLE(ZTA)
      IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 100
      IF (KODE.EQ.2) GO TO 90
C-----------------------------------------------------------------------
C OVERFLOW TEST
C-----------------------------------------------------------------------
      IF (AA.GT.(-ALIM)) GO TO 90
      AA = -AA + 0.25E0*ALAZ
      IFLAG = 1
      SFAC = TOL
      IF (AA.GT.ELIM) GO TO 240
   90 CONTINUE
C-----------------------------------------------------------------------
C CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2
C-----------------------------------------------------------------------
      MR = 1
      IF (ZI.LT.0.0E0) MR = -1
      CALL CACAI(ZTA, FNU, KODE, MR, 1, CY, NN, RL, TOL, ELIM, ALIM)
      IF (NN.LT.0) GO TO 250
      NZ = NZ + NN
      GO TO 120
  100 CONTINUE
      IF (KODE.EQ.2) GO TO 110
C-----------------------------------------------------------------------
C UNDERFLOW TEST
C-----------------------------------------------------------------------
      IF (AA.LT.ALIM) GO TO 110
      AA = -AA - 0.25E0*ALAZ
      IFLAG = 2
      SFAC = 1.0E0/TOL
      IF (AA.LT.(-ELIM)) GO TO 180
  110 CONTINUE
      CALL CBKNU(ZTA, FNU, KODE, 1, CY, NZ, TOL, ELIM, ALIM)
  120 CONTINUE
C S1 = CY(1)*DCMPLX(COEF,0.0E0)
      S1= CY(1)*COEF
      IF (IFLAG.NE.0) GO TO 140
      IF (ID.EQ.1) GO TO 130
      AI = CSQ*S1
      RETURN
  130 AI = -Z*S1
      RETURN
  140 CONTINUE
C S1 = S1*DCMPLX(SFAC,0.0E0)
      S1= S1*SFAC
      IF (ID.EQ.1) GO TO 150
      S1 = S1*CSQ
C AI = S1*DCMPLX(1.0E0/SFAC,0.0E0)
      AI= S1/SFAC
      RETURN
  150 CONTINUE
      S1 = -S1*Z
C AI = S1*DCMPLX(1.0E0/SFAC,0.0E0)
      AI= S1/SFAC
      RETURN
  160 CONTINUE
      AA = 1.0E+3*R1MACH(1)
C S1 = DCMPLX(0.0E0,0.0E0)
      S1= 0.
      IF (ID.EQ.1) GO TO 170
C IF (AZ.GT.AA) S1 = DCMPLX(C2,0.0E0)*Z
      IF (AZ.GT.AA) S1 = C2*Z
C AI = DCMPLX(C1,0.0E0) - S1
      AI= C1-S1
      RETURN
  170 CONTINUE
C AI = -DCMPLX(C2,0.0E0)
      AI= -C2
      AA = SQRT(AA)
C IF (AZ.GT.AA) S1 = Z*Z*DCMPLX(0.5E0,0.0E0)
      IF (AZ.GT.AA) S1 = Z**2/2
C AI = AI + S1*DCMPLX(C1,0.0E0)
      AI= AI+S1*C1
      RETURN
  180 CONTINUE
      NZ = 1
C AI = DCMPLX(0.0E0,0.0E0)
      AI= 0.
      RETURN
  240 CONTINUE
      NZ = 0
      IERR=2
      RETURN
  250 CONTINUE
      IF(NN.EQ.(-1)) GO TO 240
      NZ=0
      IERR=5
      RETURN
  260 CONTINUE
      IERR=4
      NZ=0
      RETURN
      END
      SUBROUTINE CBIRY(Z, ID, KODE, BI, IERR)
C***BEGIN PROLOGUE CBIRY
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR DOUBLECOMPLEX Z
C***DESCRIPTION
C
C ON KODE=1, CBIRY COMPUTES THE DOUBLECOMPLEX AIRY FUNCTION BI(Z) OR
C ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
C KODE=2, A SCALING OPTION ZEXP(-AXZTA)*BI(Z) OR ZEXP(-AXZTA)*
C DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN
C BOTH THE LEFT AND RIGHT HALF PLANES WHERE
C ZTA=(2/3)*Z*ZSQRT(Z)=DCMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA).
C DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
C MATHEMATICAL FUNCTIONS (REF. 1).
C
C INPUT
C Z - Z=DCMPLX(X,Y)
C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C BI=BI(Z) ON ID=0 OR
C BI=DBI(Z)/DZ ON ID=1
C = 2 RETURNS
C BI=ZEXP(-AXZTA)*BI(Z) ON ID=0 OR
C BI=ZEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE
C ZTA=(2/3)*Z*ZSQRT(Z)=DCMPLX(XZTA,YZTA)
C AND AXZTA=ABS(XZTA)
C
C OUTPUT
C BI - DOUBLECOMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
C KODE
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, DBLE(Z)
C TOO LARGE WITH KODE=1
C IERR=3, ZABS(Z) LARGE - COMPUTATION COMPLETED
C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
C PRODUCE LESS THAN HALF OF MACHINE ACCURACY
C IERR=4, ZABS(Z) TOO LARGE - NO COMPUTATION
C COMPLETE LOSS OF ACCURACY BY ARGUMENT
C REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C BI AND DBI ARE COMPUTED FOR ZABS(Z).GT.1.0 FROM THE I BESSEL
C FUNCTIONS BY
C
C BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) )
C DBI(Z)=C * Z * ( I(-2/3,ZTA) + I(2/3,ZTA) )
C C=1.0/SQRT(3.0)
C ZTA=(2/3)*Z**(3/2)
C
C WITH THE POWER SERIES FOR ZABS(Z).LE.1.0.
C
C IN MOST DOUBLECOMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
C FLAG IERR=3 IS TRIGGERED WHERE UR=R1MACH(4)=UNIT ROUNDOFF.
C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
C PRECISION ARITHMETIC.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A DOUBLECOMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(ZABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C ZABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C BECAUSE, IN DOUBLECOMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C OR -PI/2+P.
C
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A DOUBLECOMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED CBINU,I1MACH,R1MACH
C***END PROLOGUE CBIRY
      DOUBLECOMPLEX
     1 BI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3
      DOUBLEPRECISION
     1 AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BK, CK, COEF, C1, C2,
     * DIG, DK, D1, D2, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, SFAC,
     * TOL, TTH, ZI, ZR, Z3I, Z3R, R1MACH, ALAZ
      INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH
      DIMENSION CY(2)
      DATA TTH, C1, C2, COEF, PI /6.66666666666666667E-01,
     * 6.14926627446000736E-01,4.48288357353826359E-01,
     * 5.77350269189625765E-01,3.14159265358979324E+00/
      DATA CONE / (1.0E0,0.0E0) /
C***FIRST EXECUTABLE STATEMENT CBIRY
      IERR = 0
      NZ=0
      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (IERR.NE.0) RETURN
      AZ = ZABS(Z)
      TOL = DMAX1(R1MACH(4),DBLE(1.0E-18))
      FID = FLOAT(ID)
      IF (AZ.GT.1.0E0) GO TO 60
C-----------------------------------------------------------------------
C POWER SERIES FOR ZABS(Z).LE.1.
C-----------------------------------------------------------------------
      S1 = CONE
      S2 = CONE
      IF (AZ.LT.TOL) GO TO 110
      AA = AZ*AZ
      IF (AA.LT.TOL/AZ) GO TO 40
      TRM1 = CONE
      TRM2 = CONE
      ATRM = 1.0E0
      Z3 = Z*Z*Z
      AZ3 = AZ*AA
      AK = 2.0E0 + FID
      BK = 3.0E0 - FID - FID
      CK = 4.0E0 - FID
      DK = 3.0E0 + FID + FID
      D1 = AK*DK
      D2 = BK*CK
      AD = DMIN1(D1,D2)
      AK = 24.0E0 + 9.0E0*FID
      BK = 30.0E0 - 9.0E0*FID
      Z3R = DBLE(Z3)
      Z3I = DIMAG(Z3)
      DO 30 K=1,25
        TRM1 = TRM1*DCMPLX(Z3R/D1,Z3I/D1)
        S1 = S1 + TRM1
        TRM2 = TRM2*DCMPLX(Z3R/D2,Z3I/D2)
        S2 = S2 + TRM2
        ATRM = ATRM*AZ3/AD
        D1 = D1 + AK
        D2 = D2 + BK
        AD = DMIN1(D1,D2)
        IF (ATRM.LT.TOL*AD) GO TO 40
        AK = AK + 18.0E0
        BK = BK + 18.0E0
   30 CONTINUE
   40 CONTINUE
      IF (ID.EQ.1) GO TO 50
C BI = S1*DCMPLX(C1,0.0E0) + Z*S2*DCMPLX(C2,0.0E0)
      BI = S1*C1 + Z*S2*C2
      IF (KODE.EQ.1) RETURN
C ZTA = Z*ZSQRT(Z)*DCMPLX(TTH,0.0E0)
      ZTA = Z*ZSQRT(Z)*TTH
      AA = DBLE(ZTA)
      AA = -ABS(AA)
C BI = BI*DCMPLX(EXP(AA),0.0E0)
      BI = BI*EXP(AA)
      RETURN
   50 CONTINUE
C BI = S2*DCMPLX(C2,0.0E0)
C IF (AZ.GT.TOL) BI = BI + Z*Z*S1*DCMPLX(C1/(1.0E0+FID),0.0E0)
      BI = S2*C2
      IF (AZ.GT.TOL) BI = BI + Z*Z*S1*C1/(1.+FID)
      IF (KODE.EQ.1) RETURN
C ZTA = Z*ZSQRT(Z)*DCMPLX(TTH,0.0E0)
C AA = DBLE(ZTA)
C AA = -ABS(AA)
C BI = BI*DCMPLX(EXP(AA),0.0E0)
      ZTA = Z*ZSQRT(Z)*TTH
      AA = DBLE(ZTA)
      AA = -ABS(AA)
      BI = BI*EXP(AA)
      RETURN
C-----------------------------------------------------------------------
C CASE FOR ZABS(Z).GT.1.0
C-----------------------------------------------------------------------
   60 CONTINUE
      FNU = (1.0E0+FID)/3.0E0
C-----------------------------------------------------------------------
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
C-----------------------------------------------------------------------
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN0(IABS(K1),IABS(K2))
      ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*FLOAT(K1)
      DIG = DMIN1(AA,DBLE(18.0E0))
      AA = AA*2.303E0
      ALIM = ELIM + DMAX1(-AA,DBLE(-41.45E0))
      RL = 1.2E0*DIG + 3.0E0
      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
      ALAZ=DLOG(AZ)
C-----------------------------------------------------------------------
C TEST FOR RANGE
C-----------------------------------------------------------------------
      AA=0.5E0/TOL
      BB=FLOAT(I1MACH(9))*0.5E0
      AA=DMIN1(AA,BB)
      AA=AA**TTH
      IF (AZ.GT.AA) GO TO 190
      AA=SQRT(AA)
      IF (AZ.GT.AA) IERR=3
      CSQ=ZSQRT(Z)
C ZTA=Z*CSQ*DCMPLX(TTH,0.0E0)
      ZTA=Z*CSQ*TTH
C-----------------------------------------------------------------------
C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
C-----------------------------------------------------------------------
      SFAC = 1.0E0
      ZI = DIMAG(Z)
      ZR = DBLE(Z)
      AK = DIMAG(ZTA)
      IF (ZR.GE.0.0E0) GO TO 70
      BK = DBLE(ZTA)
      CK = -ABS(BK)
      ZTA = DCMPLX(CK,AK)
   70 CONTINUE
C IF (ZI.EQ.0.0E0 .AND. ZR.LE.0.0E0) ZTA = DCMPLX(0.0E0,AK)
      IF (ZI.EQ.0.0E0 .AND. ZR.LE.0.0E0) ZTA = (0.,1.)*AK
      AA = DBLE(ZTA)
      IF (KODE.EQ.2) GO TO 80
C-----------------------------------------------------------------------
C OVERFLOW TEST
C-----------------------------------------------------------------------
      BB = ABS(AA)
      IF (BB.LT.ALIM) GO TO 80
      BB = BB + 0.25E0*DLOG(AZ)
      SFAC = TOL
      IF (BB.GT.ELIM) GO TO 170
   80 CONTINUE
      FMR = 0.0E0
      IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 90
      FMR = PI
      IF (ZI.LT.0.0E0) FMR = -PI
      ZTA = -ZTA
   90 CONTINUE
C-----------------------------------------------------------------------
C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBINU
C-----------------------------------------------------------------------
      CALL CBINU(ZTA, FNU, KODE, 1, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
      IF (NZ.LT.0) GO TO 180
      AA = FMR*FNU
C Z3 = DCMPLX(SFAC,0.0E0)
      Z3 = SFAC
      S1 = CY(1)*DCMPLX(COS(AA),SIN(AA))*Z3
      FNU = (2.0E0-FID)/3.0E0
      CALL CBINU(ZTA, FNU, KODE, 2, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
      CY(1) = CY(1)*Z3
      CY(2) = CY(2)*Z3
C-----------------------------------------------------------------------
C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
C-----------------------------------------------------------------------
C S2 = CY(1)*DCMPLX(FNU+FNU,0.0E0)/ZTA + CY(2)
      S2 = CY(1)*(FNU+FNU)/ZTA + CY(2)
      AA = FMR*(FNU-1.0E0)
C S1 = (S1+S2*DCMPLX(COS(AA),SIN(AA)))*DCMPLX(COEF,0.0E0)
      S1 = (S1+S2*DCMPLX(COS(AA),SIN(AA)))*COEF
      IF (ID.EQ.1) GO TO 100
      S1 = CSQ*S1
C BI = S1*DCMPLX(1.0E0/SFAC,0.0E0)
      BI = S1/SFAC
      RETURN
  100 CONTINUE
      S1 = Z*S1
C BI = S1*DCMPLX(1.0E0/SFAC,0.0E0)
      BI = S1/SFAC
      RETURN
  110 CONTINUE
      AA = C1*(1.0E0-FID) + FID*C2
C BI = DCMPLX(AA,0.0E0)
      BI = AA
      RETURN
  170 CONTINUE
      NZ=0
      IERR=2
      RETURN
  180 CONTINUE
      IF(NZ.EQ.(-1)) GO TO 170
      NZ=0
      IERR=5
      RETURN
  190 CONTINUE
      IERR=4
      NZ=0
      RETURN
      END
      SUBROUTINE CUNIK(ZR, FNU, IKFLG, IPMTR, TOL, INIT, PHI, ZETA1,
     * ZETA2, SUM, CWRK)
C***BEGIN PROLOGUE CUNIK
C***REFER TO CBESI,CBESK
C
C CUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC
C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2
C RESPECTIVELY BY
C
C W(FNU,ZR) = PHI*EXP(ZETA)*SUM
C
C WHERE ZETA=-ZETA1 + ZETA2 OR
C ZETA1 - ZETA2
C
C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE
C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG=
C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A DOUBLECOMPLEX WORK
C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI,
C ZETA1,ZETA2.
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE CUNIK
      DOUBLECOMPLEX
     1 CFN, CON, CONE, CRFN, CWRK, CZERO, PHI, S, SR, SUM, T,
     * T2, ZETA1, ZETA2, ZN, ZR
      DOUBLEPRECISION
     1 AC, C, FNU, RFN, TEST, TOL, TSTR, TSTI
      INTEGER I, IKFLG, INIT, IPMTR, J, K, L
      DIMENSION C(120), CWRK(16), CON(2)
      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
      DATA CON(1), CON(2) /
     1(3.98942280401432678E-01,0.0E0),(1.25331413731550025E+00,0.0E0)/
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2 C(19), C(20), C(21), C(22), C(23), C(24)/
     3 1.00000000000000000E+00, -2.08333333333333333E-01,
     4 1.25000000000000000E-01, 3.34201388888888889E-01,
     5 -4.01041666666666667E-01, 7.03125000000000000E-02,
     6 -1.02581259645061728E+00, 1.84646267361111111E+00,
     7 -8.91210937500000000E-01, 7.32421875000000000E-02,
     8 4.66958442342624743E+00, -1.12070026162229938E+01,
     9 8.78912353515625000E+00, -2.36408691406250000E+00,
     A 1.12152099609375000E-01, -2.82120725582002449E+01,
     B 8.46362176746007346E+01, -9.18182415432400174E+01,
     C 4.25349987453884549E+01, -7.36879435947963170E+00,
     D 2.27108001708984375E-01, 2.12570130039217123E+02,
     E -7.65252468141181642E+02, 1.05999045252799988E+03/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3 -6.99579627376132541E+02, 2.18190511744211590E+02,
     4 -2.64914304869515555E+01, 5.72501420974731445E-01,
     5 -1.91945766231840700E+03, 8.06172218173730938E+03,
     6 -1.35865500064341374E+04, 1.16553933368645332E+04,
     7 -5.30564697861340311E+03, 1.20090291321635246E+03,
     8 -1.08090919788394656E+02, 1.72772750258445740E+00,
     9 2.02042913309661486E+04, -9.69805983886375135E+04,
     A 1.92547001232531532E+05, -2.03400177280415534E+05,
     B 1.22200464983017460E+05, -4.11926549688975513E+04,
     C 7.10951430248936372E+03, -4.93915304773088012E+02,
     D 6.07404200127348304E+00, -2.42919187900551333E+05,
     E 1.31176361466297720E+06, -2.99801591853810675E+06/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
     3 3.76327129765640400E+06, -2.81356322658653411E+06,
     4 1.26836527332162478E+06, -3.31645172484563578E+05,
     5 4.52187689813627263E+04, -2.49983048181120962E+03,
     6 2.43805296995560639E+01, 3.28446985307203782E+06,
     7 -1.97068191184322269E+07, 5.09526024926646422E+07,
     8 -7.41051482115326577E+07, 6.63445122747290267E+07,
     9 -3.75671766607633513E+07, 1.32887671664218183E+07,
     A -2.78561812808645469E+06, 3.08186404612662398E+05,
     B -1.38860897537170405E+04, 1.10017140269246738E+02,
     C -4.93292536645099620E+07, 3.25573074185765749E+08,
     D -9.39462359681578403E+08, 1.55359689957058006E+09,
     E -1.62108055210833708E+09, 1.10684281682301447E+09/
      DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
     1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
     2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
     3 -4.95889784275030309E+08, 1.42062907797533095E+08,
     4 -2.44740627257387285E+07, 2.24376817792244943E+06,
     5 -8.40054336030240853E+04, 5.51335896122020586E+02,
     6 8.14789096118312115E+08, -5.86648149205184723E+09,
     7 1.86882075092958249E+10, -3.46320433881587779E+10,
     8 4.12801855797539740E+10, -3.30265997498007231E+10,
     9 1.79542137311556001E+10, -6.56329379261928433E+09,
     A 1.55927986487925751E+09, -2.25105661889415278E+08,
     B 1.73951075539781645E+07, -5.49842327572288687E+05,
     C 3.03809051092238427E+03, -1.46792612476956167E+10,
     D 1.14498237732025810E+11, -3.99096175224466498E+11,
     E 8.19218669548577329E+11, -1.09837515608122331E+12/
      DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104),
     1 C(105), C(106), C(107), C(108), C(109), C(110), C(111),
     2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/
     3 1.00815810686538209E+12, -6.45364869245376503E+11,
     4 2.87900649906150589E+11, -8.78670721780232657E+10,
     5 1.76347306068349694E+10, -2.16716498322379509E+09,
     6 1.43157876718888981E+08, -3.87183344257261262E+06,
     7 1.82577554742931747E+04, 2.86464035717679043E+11,
     8 -2.40629790002850396E+12, 9.10934118523989896E+12,
     9 -2.05168994109344374E+13, 3.05651255199353206E+13,
     A -3.16670885847851584E+13, 2.33483640445818409E+13,
     B -1.23204913055982872E+13, 4.61272578084913197E+12,
     C -1.19655288019618160E+12, 2.05914503232410016E+11,
     D -2.18229277575292237E+10, 1.24700929351271032E+09/
      DATA C(119), C(120)/
     1 -2.91883881222208134E+07, 1.18838426256783253E+05/
C
      IF (INIT.NE.0) GO TO 40
C-----------------------------------------------------------------------
C INITIALIZE ALL VARIABLES
C-----------------------------------------------------------------------
      RFN = 1.0E0/FNU
C CRFN = DCMPLX(RFN,0.0E0)
      CRFN = RFN
      T = ZR*CRFN
      S = CONE + T*T
      SR = ZSQRT(S)
C CFN = DCMPLX(FNU,0.0E0)
      CFN = FNU
      ZN = (CONE+SR)/T
      ZETA1 = CFN*ZLOG(ZN)
      ZETA2 = CFN*SR
      T = CONE/SR
      SR = T*CRFN
      CWRK(16) = ZSQRT(SR)
      PHI = CWRK(16)*CON(IKFLG)
      IF (IPMTR.NE.0) RETURN
      T2 = CONE/S
      CWRK(1) = CONE
      CRFN = CONE
      AC = 1.0E0
      L = 1
      DO 20 K=2,15
        S = CZERO
        DO 10 J=1,K
          L = L + 1
C S = S*T2 + DCMPLX(C(L),0.0E0)
          S = S*T2 + C(L)
   10 CONTINUE
        CRFN = CRFN*SR
        CWRK(K) = CRFN*S
        AC = AC*RFN
        TSTR = DBLE(CWRK(K))
        TSTI = DIMAG(CWRK(K))
        TEST = ABS(TSTR) + ABS(TSTI)
        IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30
   20 CONTINUE
      K = 15
   30 CONTINUE
      INIT = K
   40 CONTINUE
      IF (IKFLG.EQ.2) GO TO 60
C-----------------------------------------------------------------------
C COMPUTE SUM FOR THE I FUNCTION
C-----------------------------------------------------------------------
      S = CZERO
      DO 50 I=1,INIT
        S = S + CWRK(I)
   50 CONTINUE
      SUM = S
      PHI = CWRK(16)*CON(1)
      RETURN
   60 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE SUM FOR THE K FUNCTION
C-----------------------------------------------------------------------
      S = CZERO
      T = CONE
      DO 70 I=1,INIT
        S = S + T*CWRK(I)
        T = -T
   70 CONTINUE
      SUM = S
      PHI = CWRK(16)*CON(2)
      RETURN
      END
      SUBROUTINE CUOIK(Z, FNU, KODE, IKFLG, N, Y, NUF, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CUOIK
C***REFER TO CBESI,CBESK,CBESH
C
C CUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC
C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM
C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW
C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING
C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN
C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER
C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE
C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)=
C EXP(-ELIM)/TOL
C
C IKFLG=1 MEANS THE I SEQUENCE IS TESTED
C =2 MEANS THE K SEQUENCE IS TESTED
C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE
C =-1 MEANS AN OVERFLOW WOULD OCCUR
C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO
C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE
C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO
C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY
C ANOTHER ROUTINE
C
C***ROUTINES CALLED CUCHK,CUNHJ,CUNIK,R1MACH
C***END PROLOGUE CUOIK
      DOUBLECOMPLEX
     1 ARG, ASUM, BSUM, CWRK, CZ, CZERO, PHI, SUM, Y, Z, ZB,
     * ZETA1, ZETA2, ZN, ZR
      DOUBLEPRECISION
     1 AARG, AIC, ALIM, APHI, ASCLE, AX, AY, ELIM, FNN, FNU, GNN,
     * GNU, RCZ, TOL, X, YY
      INTEGER I, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW
      DOUBLEPRECISION R1MACH
      DIMENSION Y(*), CWRK(16)
      DATA CZERO / (0.0E0,0.0E0) /
      DATA AIC / 1.265512123484645396E+00 /
      NUF = 0
      NN = N
      X = DBLE(Z)
      ZR = Z
      IF (X.LT.0.0E0) ZR = -Z
      ZB = ZR
      YY = DIMAG(ZR)
      AX = ABS(X)*1.7321E0
      AY = ABS(YY)
      IFORM = 1
      IF (AY.GT.AX) IFORM = 2
      GNU = DMAX1(FNU,DBLE(1.0E0))
      IF (IKFLG.EQ.1) GO TO 10
      FNN = FLOAT(NN)
      GNN = FNU + FNN - 1.0E0
      GNU = DMAX1(GNN,FNN)
   10 CONTINUE
C-----------------------------------------------------------------------
C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE
C DOUBLEPRECISION PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET
C THE SIGN OF THE IMAGINARY PART CORRECT.
C-----------------------------------------------------------------------
      IF (IFORM.EQ.2) GO TO 20
      INIT = 0
      CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM,
     * CWRK)
      CZ = -ZETA1 + ZETA2
      GO TO 40
   20 CONTINUE
C ZN = -ZR*DCMPLX(0.0E0,1.0E0)
      ZN = ZR*(0.,-1.)
      IF (YY.GT.0.0E0) GO TO 30
      ZN = DCONJG(-ZN)
   30 CONTINUE
      CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM)
      CZ = -ZETA1 + ZETA2
      AARG = ZABS(ARG)
   40 CONTINUE
      IF (KODE.EQ.2) CZ = CZ - ZB
      IF (IKFLG.EQ.2) CZ = -CZ
      APHI = ZABS(PHI)
      RCZ = DBLE(CZ)
C-----------------------------------------------------------------------
C OVERFLOW TEST
C-----------------------------------------------------------------------
      IF (RCZ.GT.ELIM) GO TO 170
      IF (RCZ.LT.ALIM) GO TO 50
      RCZ = RCZ + DLOG(APHI)
      IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*DLOG(AARG) - AIC
      IF (RCZ.GT.ELIM) GO TO 170
      GO TO 100
   50 CONTINUE
C-----------------------------------------------------------------------
C UNDERFLOW TEST
C-----------------------------------------------------------------------
      IF (RCZ.LT.(-ELIM)) GO TO 60
      IF (RCZ.GT.(-ALIM)) GO TO 100
      RCZ = RCZ + DLOG(APHI)
      IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*DLOG(AARG) - AIC
      IF (RCZ.GT.(-ELIM)) GO TO 80
   60 CONTINUE
      DO 70 I=1,NN
        Y(I) = CZERO
   70 CONTINUE
      NUF = NN
      RETURN
   80 CONTINUE
      ASCLE = 1.0E+3*R1MACH(1)/TOL
      CZ = CZ + ZLOG(PHI)
      IF (IFORM.EQ.1) GO TO 90
C CZ = CZ - DCMPLX(0.25E0,0.0E0)*ZLOG(ARG) - DCMPLX(AIC,0.0E0)
      CZ = CZ - ZLOG(ARG)/4 - AIC
   90 CONTINUE
      AX = EXP(RCZ)/TOL
      AY = DIMAG(CZ)
C CZ = DCMPLX(AX,0.0E0)*DCMPLX(COS(AY),SIN(AY))
      CZ = AX*DCMPLX(COS(AY),SIN(AY))
      CALL CUCHK(CZ, NW, ASCLE, TOL)
      IF (NW.EQ.1) GO TO 60
  100 CONTINUE
      IF (IKFLG.EQ.2) RETURN
      IF (N.EQ.1) RETURN
C-----------------------------------------------------------------------
C SET UNDERFLOWS ON I SEQUENCE
C-----------------------------------------------------------------------
  110 CONTINUE
      GNU = FNU + FLOAT(NN-1)
      IF (IFORM.EQ.2) GO TO 120
      INIT = 0
      CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM,
     * CWRK)
      CZ = -ZETA1 + ZETA2
      GO TO 130
  120 CONTINUE
      CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM)
      CZ = -ZETA1 + ZETA2
      AARG = ZABS(ARG)
  130 CONTINUE
      IF (KODE.EQ.2) CZ = CZ - ZB
      APHI = ZABS(PHI)
      RCZ = DBLE(CZ)
      IF (RCZ.LT.(-ELIM)) GO TO 140
      IF (RCZ.GT.(-ALIM)) RETURN
      RCZ = RCZ + DLOG(APHI)
      IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*DLOG(AARG) - AIC
      IF (RCZ.GT.(-ELIM)) GO TO 150
  140 CONTINUE
      Y(NN) = CZERO
      NN = NN - 1
      NUF = NUF + 1
      IF (NN.EQ.0) RETURN
      GO TO 110
  150 CONTINUE
      ASCLE = 1.0E+3*R1MACH(1)/TOL
      CZ = CZ + ZLOG(PHI)
      IF (IFORM.EQ.1) GO TO 160
C CZ = CZ - DCMPLX(0.25E0,0.0E0)*ZLOG(ARG) - DCMPLX(AIC,0.0E0)
      CZ = CZ - ZLOG(ARG)/4 - AIC
  160 CONTINUE
      AX = EXP(RCZ)/TOL
      AY = DIMAG(CZ)
C CZ = DCMPLX(AX,0.0E0)*DCMPLX(COS(AY),SIN(AY))
      CZ = AX*DCMPLX(COS(AY),SIN(AY))
      CALL CUCHK(CZ, NW, ASCLE, TOL)
      IF (NW.EQ.1) GO TO 140
      RETURN
  170 CONTINUE
      NUF = -1
      RETURN
      END
      SUBROUTINE CWRSK(ZR, FNU, KODE, N, Y, NZ, CW, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CWRSK
C***REFER TO CBESI,CBESK
C
C CWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY
C NORMALIZING THE I FUNCTION RATIOS FROM CRATI BY THE WRONSKIAN
C
C***ROUTINES CALLED CBKNU,CRATI,R1MACH
C***END PROLOGUE CWRSK
      DOUBLECOMPLEX
     1 CINU, CSCL, CT, CW, C1, C2, RCT, ST, Y, ZR
      DOUBLEPRECISION
     1 ACT, ACW, ALIM, ASCLE, ELIM, FNU, S1, S2, TOL, YY
      DOUBLEPRECISION R1MACH
      INTEGER I, KODE, N, NW, NZ
      DIMENSION Y(*), CW(2)
C-----------------------------------------------------------------------
C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS
C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE
C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU.
C-----------------------------------------------------------------------
      NZ = 0
      CALL CBKNU(ZR, FNU, KODE, 2, CW, NW, TOL, ELIM, ALIM)
      IF (NW.NE.0) GO TO 50
      CALL CRATI(ZR, FNU, N, Y, TOL)
C-----------------------------------------------------------------------
C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),
C R(FNU+J-1,Z)=Y(J), J=1,...,N
C-----------------------------------------------------------------------
C CINU = DCMPLX(1.0E0,0.0E0)
      CINU = 1.
      IF (KODE.EQ.1) GO TO 10
      YY = DIMAG(ZR)
      S1 = COS(YY)
      S2 = SIN(YY)
      CINU = DCMPLX(S1,S2)
   10 CONTINUE
C-----------------------------------------------------------------------
C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH
C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE
C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT
C THE RESULT IS ON SCALE.
C-----------------------------------------------------------------------
      ACW = ZABS(CW(2))
      ASCLE = 1.0E+3*R1MACH(1)/TOL
C CSCL = DCMPLX(1.0E0,0.0E0)
      CSCL = 1.
      IF (ACW.GT.ASCLE) GO TO 20
C CSCL = DCMPLX(1.0E0/TOL,0.0E0)
      CSCL = 1./TOL
      GO TO 30
   20 CONTINUE
      ASCLE = 1.0E0/ASCLE
      IF (ACW.LT.ASCLE) GO TO 30
C CSCL = DCMPLX(TOL,0.0E0)
      CSCL = TOL
   30 CONTINUE
      C1 = CW(1)*CSCL
      C2 = CW(2)*CSCL
      ST = Y(1)
C-----------------------------------------------------------------------
C CINU=CINU*(DCONJG(CT)/ZABS(CT))*(1.0E0/ZABS(CT) PREVENTS
C UNDER- OR OVERFLOW PREMATURELY BY SQUARING ZABS(CT)
C-----------------------------------------------------------------------
      CT = ZR*(C2+ST*C1)
      ACT = ZABS(CT)
C RCT = DCMPLX(1.0E0/ACT,0.0E0)
      RCT = 1./ACT
      CT = DCONJG(CT)*RCT
      CINU = CINU*RCT*CT
      Y(1) = CINU*CSCL
      IF (N.EQ.1) RETURN
      DO 40 I=2,N
        CINU = ST*CINU
        ST = Y(I)
        Y(I) = CINU*CSCL
   40 CONTINUE
      RETURN
   50 CONTINUE
      NZ = -1
      IF(NW.EQ.(-2)) NZ=-2
      RETURN
      END
      SUBROUTINE CMLRI(Z, FNU, KODE, N, Y, NZ, TOL)
C***BEGIN PROLOGUE CMLRI
C***REFER TO CBESI,CBESK
C
C CMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE
C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES.
C
C***ROUTINES CALLED GAMLN,R1MACH
C***END PROLOGUE CMLRI
      DOUBLECOMPLEX
     1 CK, CNORM, CONE, CTWO, CZERO, PT, P1, P2, RZ, SUM, Y, Z
      DOUBLEPRECISION
     1 ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, FNU, RHO,
     * RHO2, SCLE, TFNF, TOL, TST, X, GAMLN, R1MACH
      INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N
      INTEGER NZ
      DIMENSION Y(*)
      DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/
      SCLE = 1.0E+3*R1MACH(1)/TOL
      NZ=0
      AZ = ZABS(Z)
      X = DBLE(Z)
      IAZ = INT(AZ)
      IFNU = INT(FNU)
      INU = IFNU + N - 1
      AT = FLOAT(IAZ) + 1.0E0
C CK = DCMPLX(AT,0.0E0)/Z
      CK = AT/Z
      RZ = CTWO/Z
      P1 = CZERO
      P2 = CONE
      ACK = (AT+1.0E0)/AZ
      RHO = ACK + SQRT(ACK*ACK-1.0E0)
      RHO2 = RHO*RHO
      TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0))
      TST = TST/TOL
C-----------------------------------------------------------------------
C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES
C-----------------------------------------------------------------------
      AK = AT
      DO 10 I=1,80
        PT = P2
        P2 = P1 - CK*P2
        P1 = PT
        CK = CK + RZ
        AP = ZABS(P2)
        IF (AP.GT.TST*AK*AK) GO TO 20
        AK = AK + 1.0E0
   10 CONTINUE
      GO TO 110
   20 CONTINUE
      I = I + 1
      K = 0
      IF (INU.LT.IAZ) GO TO 40
C-----------------------------------------------------------------------
C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS
C-----------------------------------------------------------------------
      P1 = CZERO
      P2 = CONE
      AT = FLOAT(INU) + 1.0E0
C CK = DCMPLX(AT,0.0E0)/Z
      CK = AT/Z
      ACK = AT/AZ
      TST = SQRT(ACK/TOL)
      ITIME = 1
      DO 30 K=1,80
        PT = P2
        P2 = P1 - CK*P2
        P1 = PT
        CK = CK + RZ
        AP = ZABS(P2)
        IF (AP.LT.TST) GO TO 30
        IF (ITIME.EQ.2) GO TO 40
        ACK = ZABS(CK)
        FLAM = ACK + SQRT(ACK*ACK-1.0E0)
        FKAP = AP/ZABS(P1)
        RHO = DMIN1(FLAM,FKAP)
        TST = TST*SQRT(RHO/(RHO*RHO-1.0E0))
        ITIME = 2
   30 CONTINUE
      GO TO 110
   40 CONTINUE
C-----------------------------------------------------------------------
C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION
C-----------------------------------------------------------------------
      K = K + 1
      KK = MAX0(I+IAZ,K+INU)
      FKK = FLOAT(KK)
      P1 = CZERO
C-----------------------------------------------------------------------
C SCALE P2 AND SUM BY SCLE
C-----------------------------------------------------------------------
C P2 = DCMPLX(SCLE,0.0E0)
      P2 = SCLE
      FNF = FNU - FLOAT(IFNU)
      TFNF = FNF + FNF
      BK = GAMLN(DBLE(FKK+TFNF+1.0E0),IDUM)
     1 - GAMLN(DBLE(FKK+1.0E0),IDUM)
     * -GAMLN(DBLE(TFNF+1.0E0),IDUM)
      BK = EXP(BK)
      SUM = CZERO
      KM = KK - INU
      DO 50 I=1,KM
        PT = P2
C P2 = P1 + DCMPLX(FKK+FNF,0.0E0)*RZ*P2
        P2 = P1 + (FKK+FNF)*RZ*P2
        P1 = PT
        AK = 1.0E0 - TFNF/(FKK+TFNF)
        ACK = BK*AK
C SUM = SUM + DCMPLX(ACK+BK,0.0E0)*P1
        SUM = SUM + (ACK+BK)*P1
        BK = ACK
        FKK = FKK - 1.0E0
   50 CONTINUE
      Y(N) = P2
      IF (N.EQ.1) GO TO 70
      DO 60 I=2,N
        PT = P2
C P2 = P1 + DCMPLX(FKK+FNF,0.0E0)*RZ*P2
        P2 = P1 + (FKK+FNF)*RZ*P2
        P1 = PT
        AK = 1.0E0 - TFNF/(FKK+TFNF)
        ACK = BK*AK
C SUM = SUM + DCMPLX(ACK+BK,0.0E0)*P1
        SUM = SUM + (ACK+BK)*P1
        BK = ACK
        FKK = FKK - 1.0E0
        M = N - I + 1
        Y(M) = P2
   60 CONTINUE
   70 CONTINUE
      IF (IFNU.LE.0) GO TO 90
      DO 80 I=1,IFNU
        PT = P2
C P2 = P1 + DCMPLX(FKK+FNF,0.0E0)*RZ*P2
        P2 = P1 + (FKK+FNF)*RZ*P2
        P1 = PT
        AK = 1.0E0 - TFNF/(FKK+TFNF)
        ACK = BK*AK
C SUM = SUM + DCMPLX(ACK+BK,0.0E0)*P1
        SUM = SUM + (ACK+BK)*P1
        BK = ACK
        FKK = FKK - 1.0E0
   80 CONTINUE
   90 CONTINUE
      PT = Z
C IF (KODE.EQ.2) PT = PT - DCMPLX(X,0.0E0)
C P1 = -DCMPLX(FNF,0.0E0)*ZLOG(RZ) + PT
      IF (KODE.EQ.2) PT = PT - X
      P1 = -FNF*ZLOG(RZ) + PT
      AP = GAMLN(DBLE(1.0E0+FNF),IDUM)
C PT = P1 - DCMPLX(AP,0.0E0)
      PT = P1 - AP
C-----------------------------------------------------------------------
C THE DIVISION ZEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW
C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES
C-----------------------------------------------------------------------
      P2 = P2 + SUM
      AP = ZABS(P2)
C P1 = DCMPLX(1.0E0/AP,0.0E0)
      P1 = 1./AP
      CK = ZEXP(PT)*P1
      PT = DCONJG(P2)*P1
      CNORM = CK*PT
      DO 100 I=1,N
        Y(I) = Y(I)*CNORM
  100 CONTINUE
      RETURN
  110 CONTINUE
      NZ=-2
      RETURN
      END
      SUBROUTINE CUNHJ(Z, FNU, IPMTR, TOL, PHI, ARG, ZETA1, ZETA2,
     * ASUM, BSUM)
C***BEGIN PROLOGUE CUNHJ
C***REFER TO CBESI,CBESK
C
C REFERENCES
C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A.
C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9.
C
C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC
C PRESS, N.Y., 1974, PAGE 420
C
C ABSTRACT
C CUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) =
C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU
C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION
C
C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) )
C
C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS
C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE.
C
C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2,
C
C ZETA1=0.5*FNU*ZLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING
C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY.
C
C MCONJ=SIGN OF DIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS DOUBLEPRECISION AND
C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR=
C 1 COMPUTES ALL EXCEPT ASUM AND BSUM.
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE CUNHJ
      DOUBLECOMPLEX
     1 ARG, ASUM, BSUM, CFNU, CONE, CR, CZERO, DR, P, PHI,
     * PRZTH, PTFN, RFN13, RTZTA, RZTH, SUMA, SUMB, TFN, T2, UP, W, W2,
     * Z, ZA, ZB, ZC, ZETA, ZETA1, ZETA2, ZTH
      DOUBLEPRECISION
     1 ALFA, ANG, AP, AR, ATOL, AW2, AZTH, BETA, BR, BTOL, C, EX1,
     * EX2, FNU, FN13, FN23, GAMA, HPI, PI, PP, RFNU, RFNU2, THPI, TOL,
     * WI, WR, ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR, ASUMR, ASUMI, BSUMR,
     * BSUMI, TEST
      INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR,
     * LRP1, L1, L2, M
      DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30),
     * AP(30), P(30), UP(14), CR(14), DR(14)
      DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8),
     1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/
     2 1.00000000000000000E+00, 1.04166666666666667E-01,
     3 8.35503472222222222E-02, 1.28226574556327160E-01,
     4 2.91849026464140464E-01, 8.81627267443757652E-01,
     5 3.32140828186276754E+00, 1.49957629868625547E+01,
     6 7.89230130115865181E+01, 4.74451538868264323E+02,
     7 3.20749009089066193E+03, 2.40865496408740049E+04,
     8 1.98923119169509794E+05, 1.79190200777534383E+06/
      DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8),
     1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/
     2 1.00000000000000000E+00, -1.45833333333333333E-01,
     3 -9.87413194444444444E-02, -1.43312053915895062E-01,
     4 -3.17227202678413548E-01, -9.42429147957120249E-01,
     5 -3.51120304082635426E+00, -1.57272636203680451E+01,
     6 -8.22814390971859444E+01, -4.92355370523670524E+02,
     7 -3.31621856854797251E+03, -2.48276742452085896E+04,
     8 -2.04526587315129788E+05, -1.83844491706820990E+06/
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2 C(19), C(20), C(21), C(22), C(23), C(24)/
     3 1.00000000000000000E+00, -2.08333333333333333E-01,
     4 1.25000000000000000E-01, 3.34201388888888889E-01,
     5 -4.01041666666666667E-01, 7.03125000000000000E-02,
     6 -1.02581259645061728E+00, 1.84646267361111111E+00,
     7 -8.91210937500000000E-01, 7.32421875000000000E-02,
     8 4.66958442342624743E+00, -1.12070026162229938E+01,
     9 8.78912353515625000E+00, -2.36408691406250000E+00,
     A 1.12152099609375000E-01, -2.82120725582002449E+01,
     B 8.46362176746007346E+01, -9.18182415432400174E+01,
     C 4.25349987453884549E+01, -7.36879435947963170E+00,
     D 2.27108001708984375E-01, 2.12570130039217123E+02,
     E -7.65252468141181642E+02, 1.05999045252799988E+03/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3 -6.99579627376132541E+02, 2.18190511744211590E+02,
     4 -2.64914304869515555E+01, 5.72501420974731445E-01,
     5 -1.91945766231840700E+03, 8.06172218173730938E+03,
     6 -1.35865500064341374E+04, 1.16553933368645332E+04,
     7 -5.30564697861340311E+03, 1.20090291321635246E+03,
     8 -1.08090919788394656E+02, 1.72772750258445740E+00,
     9 2.02042913309661486E+04, -9.69805983886375135E+04,
     A 1.92547001232531532E+05, -2.03400177280415534E+05,
     B 1.22200464983017460E+05, -4.11926549688975513E+04,
     C 7.10951430248936372E+03, -4.93915304773088012E+02,
     D 6.07404200127348304E+00, -2.42919187900551333E+05,
     E 1.31176361466297720E+06, -2.99801591853810675E+06/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
     3 3.76327129765640400E+06, -2.81356322658653411E+06,
     4 1.26836527332162478E+06, -3.31645172484563578E+05,
     5 4.52187689813627263E+04, -2.49983048181120962E+03,
     6 2.43805296995560639E+01, 3.28446985307203782E+06,
     7 -1.97068191184322269E+07, 5.09526024926646422E+07,
     8 -7.41051482115326577E+07, 6.63445122747290267E+07,
     9 -3.75671766607633513E+07, 1.32887671664218183E+07,
     A -2.78561812808645469E+06, 3.08186404612662398E+05,
     B -1.38860897537170405E+04, 1.10017140269246738E+02,
     C -4.93292536645099620E+07, 3.25573074185765749E+08,
     D -9.39462359681578403E+08, 1.55359689957058006E+09,
     E -1.62108055210833708E+09, 1.10684281682301447E+09/
      DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
     1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
     2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
     3 -4.95889784275030309E+08, 1.42062907797533095E+08,
     4 -2.44740627257387285E+07, 2.24376817792244943E+06,
     5 -8.40054336030240853E+04, 5.51335896122020586E+02,
     6 8.14789096118312115E+08, -5.86648149205184723E+09,
     7 1.86882075092958249E+10, -3.46320433881587779E+10,
     8 4.12801855797539740E+10, -3.30265997498007231E+10,
     9 1.79542137311556001E+10, -6.56329379261928433E+09,
     A 1.55927986487925751E+09, -2.25105661889415278E+08,
     B 1.73951075539781645E+07, -5.49842327572288687E+05,
     C 3.03809051092238427E+03, -1.46792612476956167E+10,
     D 1.14498237732025810E+11, -3.99096175224466498E+11,
     E 8.19218669548577329E+11, -1.09837515608122331E+12/
      DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104),
     1 C(105)/
     2 1.00815810686538209E+12, -6.45364869245376503E+11,
     3 2.87900649906150589E+11, -8.78670721780232657E+10,
     4 1.76347306068349694E+10, -2.16716498322379509E+09,
     5 1.43157876718888981E+08, -3.87183344257261262E+06,
     6 1.82577554742931747E+04/
      DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6),
     1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12),
     2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18),
     3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/
     4 -4.44444444444444444E-03, -9.22077922077922078E-04,
     5 -8.84892884892884893E-05, 1.65927687832449737E-04,
     6 2.46691372741792910E-04, 2.65995589346254780E-04,
     7 2.61824297061500945E-04, 2.48730437344655609E-04,
     8 2.32721040083232098E-04, 2.16362485712365082E-04,
     9 2.00738858762752355E-04, 1.86267636637545172E-04,
     A 1.73060775917876493E-04, 1.61091705929015752E-04,
     B 1.50274774160908134E-04, 1.40503497391269794E-04,
     C 1.31668816545922806E-04, 1.23667445598253261E-04,
     D 1.16405271474737902E-04, 1.09798298372713369E-04,
     E 1.03772410422992823E-04, 9.82626078369363448E-05/
      DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28),
     1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34),
     2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40),
     3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/
     4 9.32120517249503256E-05, 8.85710852478711718E-05,
     5 8.42963105715700223E-05, 8.03497548407791151E-05,
     6 7.66981345359207388E-05, 7.33122157481777809E-05,
     7 7.01662625163141333E-05, 6.72375633790160292E-05,
     8 6.93735541354588974E-04, 2.32241745182921654E-04,
     9 -1.41986273556691197E-05, -1.16444931672048640E-04,
     A -1.50803558053048762E-04, -1.55121924918096223E-04,
     B -1.46809756646465549E-04, -1.33815503867491367E-04,
     C -1.19744975684254051E-04, -1.06184319207974020E-04,
     D -9.37699549891194492E-05, -8.26923045588193274E-05,
     E -7.29374348155221211E-05, -6.44042357721016283E-05/
      DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50),
     1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56),
     2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62),
     3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/
     4 -5.69611566009369048E-05, -5.04731044303561628E-05,
     5 -4.48134868008882786E-05, -3.98688727717598864E-05,
     6 -3.55400532972042498E-05, -3.17414256609022480E-05,
     7 -2.83996793904174811E-05, -2.54522720634870566E-05,
     8 -2.28459297164724555E-05, -2.05352753106480604E-05,
     9 -1.84816217627666085E-05, -1.66519330021393806E-05,
     A -1.50179412980119482E-05, -1.35554031379040526E-05,
     B -1.22434746473858131E-05, -1.10641884811308169E-05,
     C -3.54211971457743841E-04, -1.56161263945159416E-04,
     D 3.04465503594936410E-05, 1.30198655773242693E-04,
     E 1.67471106699712269E-04, 1.70222587683592569E-04/
      DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72),
     1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78),
     2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84),
     3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/
     4 1.56501427608594704E-04, 1.36339170977445120E-04,
     5 1.14886692029825128E-04, 9.45869093034688111E-05,
     6 7.64498419250898258E-05, 6.07570334965197354E-05,
     7 4.74394299290508799E-05, 3.62757512005344297E-05,
     8 2.69939714979224901E-05, 1.93210938247939253E-05,
     9 1.30056674793963203E-05, 7.82620866744496661E-06,
     A 3.59257485819351583E-06, 1.44040049814251817E-07,
     B -2.65396769697939116E-06, -4.91346867098485910E-06,
     C -6.72739296091248287E-06, -8.17269379678657923E-06,
     D -9.31304715093561232E-06, -1.02011418798016441E-05,
     E -1.08805962510592880E-05, -1.13875481509603555E-05/
      DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94),
     1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100),
     2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105),
     3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/
     4 -1.17519675674556414E-05, -1.19987364870944141E-05,
     5 3.78194199201772914E-04, 2.02471952761816167E-04,
     6 -6.37938506318862408E-05, -2.38598230603005903E-04,
     7 -3.10916256027361568E-04, -3.13680115247576316E-04,
     8 -2.78950273791323387E-04, -2.28564082619141374E-04,
     9 -1.75245280340846749E-04, -1.25544063060690348E-04,
     A -8.22982872820208365E-05, -4.62860730588116458E-05,
     B -1.72334302366962267E-05, 5.60690482304602267E-06,
     C 2.31395443148286800E-05, 3.62642745856793957E-05,
     D 4.58006124490188752E-05, 5.24595294959114050E-05,
     E 5.68396208545815266E-05, 5.94349820393104052E-05/
      DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115),
     1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120),
     2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125),
     3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/
     4 6.06478527578421742E-05, 6.08023907788436497E-05,
     5 6.01577894539460388E-05, 5.89199657344698500E-05,
     6 5.72515823777593053E-05, 5.52804375585852577E-05,
     7 5.31063773802880170E-05, 5.08069302012325706E-05,
     8 4.84418647620094842E-05, 4.60568581607475370E-05,
     9 -6.91141397288294174E-04, -4.29976633058871912E-04,
     A 1.83067735980039018E-04, 6.60088147542014144E-04,
     B 8.75964969951185931E-04, 8.77335235958235514E-04,
     C 7.49369585378990637E-04, 5.63832329756980918E-04,
     D 3.68059319971443156E-04, 1.88464535514455599E-04/
      DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135),
     1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140),
     2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145),
     3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/
     4 3.70663057664904149E-05, -8.28520220232137023E-05,
     5 -1.72751952869172998E-04, -2.36314873605872983E-04,
     6 -2.77966150694906658E-04, -3.02079514155456919E-04,
     7 -3.12594712643820127E-04, -3.12872558758067163E-04,
     8 -3.05678038466324377E-04, -2.93226470614557331E-04,
     9 -2.77255655582934777E-04, -2.59103928467031709E-04,
     A -2.39784014396480342E-04, -2.20048260045422848E-04,
     B -2.00443911094971498E-04, -1.81358692210970687E-04,
     C -1.63057674478657464E-04, -1.45712672175205844E-04,
     D -1.29425421983924587E-04, -1.14245691942445952E-04/
      DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155),
     1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160),
     2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165),
     3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/
     4 1.92821964248775885E-03, 1.35592576302022234E-03,
     5 -7.17858090421302995E-04, -2.58084802575270346E-03,
     6 -3.49271130826168475E-03, -3.46986299340960628E-03,
     7 -2.82285233351310182E-03, -1.88103076404891354E-03,
     8 -8.89531718383947600E-04, 3.87912102631035228E-06,
     9 7.28688540119691412E-04, 1.26566373053457758E-03,
     A 1.62518158372674427E-03, 1.83203153216373172E-03,
     B 1.91588388990527909E-03, 1.90588846755546138E-03,
     C 1.82798982421825727E-03, 1.70389506421121530E-03,
     D 1.55097127171097686E-03, 1.38261421852276159E-03/
      DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175),
     1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/
     2 1.20881424230064774E-03, 1.03676532638344962E-03,
     3 8.71437918068619115E-04, 7.16080155297701002E-04,
     4 5.72637002558129372E-04, 4.42089819465802277E-04,
     5 3.24724948503090564E-04, 2.20342042730246599E-04,
     6 1.28412898401353882E-04, 4.82005924552095464E-05/
      DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6),
     1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12),
     2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18),
     3 BETA(19), BETA(20), BETA(21), BETA(22)/
     4 1.79988721413553309E-02, 5.59964911064388073E-03,
     5 2.88501402231132779E-03, 1.80096606761053941E-03,
     6 1.24753110589199202E-03, 9.22878876572938311E-04,
     7 7.14430421727287357E-04, 5.71787281789704872E-04,
     8 4.69431007606481533E-04, 3.93232835462916638E-04,
     9 3.34818889318297664E-04, 2.88952148495751517E-04,
     A 2.52211615549573284E-04, 2.22280580798883327E-04,
     B 1.97541838033062524E-04, 1.76836855019718004E-04,
     C 1.59316899661821081E-04, 1.44347930197333986E-04,
     D 1.31448068119965379E-04, 1.20245444949302884E-04,
     E 1.10449144504599392E-04, 1.01828770740567258E-04/
      DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28),
     1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34),
     2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40),
     3 BETA(41), BETA(42), BETA(43), BETA(44)/
     4 9.41998224204237509E-05, 8.74130545753834437E-05,
     5 8.13466262162801467E-05, 7.59002269646219339E-05,
     6 7.09906300634153481E-05, 6.65482874842468183E-05,
     7 6.25146958969275078E-05, 5.88403394426251749E-05,
     8 -1.49282953213429172E-03, -8.78204709546389328E-04,
     9 -5.02916549572034614E-04, -2.94822138512746025E-04,
     A -1.75463996970782828E-04, -1.04008550460816434E-04,
     B -5.96141953046457895E-05, -3.12038929076098340E-05,
     C -1.26089735980230047E-05, -2.42892608575730389E-07,
     D 8.05996165414273571E-06, 1.36507009262147391E-05,
     E 1.73964125472926261E-05, 1.98672978842133780E-05/
      DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50),
     1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56),
     2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62),
     3 BETA(63), BETA(64), BETA(65), BETA(66)/
     4 2.14463263790822639E-05, 2.23954659232456514E-05,
     5 2.28967783814712629E-05, 2.30785389811177817E-05,
     6 2.30321976080909144E-05, 2.28236073720348722E-05,
     7 2.25005881105292418E-05, 2.20981015361991429E-05,
     8 2.16418427448103905E-05, 2.11507649256220843E-05,
     9 2.06388749782170737E-05, 2.01165241997081666E-05,
     A 1.95913450141179244E-05, 1.90689367910436740E-05,
     B 1.85533719641636667E-05, 1.80475722259674218E-05,
     C 5.52213076721292790E-04, 4.47932581552384646E-04,
     D 2.79520653992020589E-04, 1.52468156198446602E-04,
     E 6.93271105657043598E-05, 1.76258683069991397E-05/
      DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72),
     1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78),
     2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84),
     3 BETA(85), BETA(86), BETA(87), BETA(88)/
     4 -1.35744996343269136E-05, -3.17972413350427135E-05,
     5 -4.18861861696693365E-05, -4.69004889379141029E-05,
     6 -4.87665447413787352E-05, -4.87010031186735069E-05,
     7 -4.74755620890086638E-05, -4.55813058138628452E-05,
     8 -4.33309644511266036E-05, -4.09230193157750364E-05,
     9 -3.84822638603221274E-05, -3.60857167535410501E-05,
     A -3.37793306123367417E-05, -3.15888560772109621E-05,
     B -2.95269561750807315E-05, -2.75978914828335759E-05,
     C -2.58006174666883713E-05, -2.41308356761280200E-05,
     D -2.25823509518346033E-05, -2.11479656768912971E-05,
     E -1.98200638885294927E-05, -1.85909870801065077E-05/
      DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94),
     1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100),
     2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105),
     3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/
     4 -1.74532699844210224E-05, -1.63997823854497997E-05,
     5 -4.74617796559959808E-04, -4.77864567147321487E-04,
     6 -3.20390228067037603E-04, -1.61105016119962282E-04,
     7 -4.25778101285435204E-05, 3.44571294294967503E-05,
     8 7.97092684075674924E-05, 1.03138236708272200E-04,
     9 1.12466775262204158E-04, 1.13103642108481389E-04,
     A 1.08651634848774268E-04, 1.01437951597661973E-04,
     B 9.29298396593363896E-05, 8.40293133016089978E-05,
     C 7.52727991349134062E-05, 6.69632521975730872E-05,
     D 5.92564547323194704E-05, 5.22169308826975567E-05,
     E 4.58539485165360646E-05, 4.01445513891486808E-05/
      DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115),
     1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120),
     2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125),
     3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/
     4 3.50481730031328081E-05, 3.05157995034346659E-05,
     5 2.64956119950516039E-05, 2.29363633690998152E-05,
     6 1.97893056664021636E-05, 1.70091984636412623E-05,
     7 1.45547428261524004E-05, 1.23886640995878413E-05,
     8 1.04775876076583236E-05, 8.79179954978479373E-06,
     9 7.36465810572578444E-04, 8.72790805146193976E-04,
     A 6.22614862573135066E-04, 2.85998154194304147E-04,
     B 3.84737672879366102E-06, -1.87906003636971558E-04,
     C -2.97603646594554535E-04, -3.45998126832656348E-04,
     D -3.53382470916037712E-04, -3.35715635775048757E-04/
      DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135),
     1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140),
     2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145),
     3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/
     4 -3.04321124789039809E-04, -2.66722723047612821E-04,
     5 -2.27654214122819527E-04, -1.89922611854562356E-04,
     6 -1.55058918599093870E-04, -1.23778240761873630E-04,
     7 -9.62926147717644187E-05, -7.25178327714425337E-05,
     8 -5.22070028895633801E-05, -3.50347750511900522E-05,
     9 -2.06489761035551757E-05, -8.70106096849767054E-06,
     A 1.13698686675100290E-06, 9.16426474122778849E-06,
     B 1.56477785428872620E-05, 2.08223629482466847E-05,
     C 2.48923381004595156E-05, 2.80340509574146325E-05,
     D 3.03987774629861915E-05, 3.21156731406700616E-05/
      DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155),
     1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160),
     2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165),
     3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/
     4 -1.80182191963885708E-03, -2.43402962938042533E-03,
     5 -1.83422663549856802E-03, -7.62204596354009765E-04,
     6 2.39079475256927218E-04, 9.49266117176881141E-04,
     7 1.34467449701540359E-03, 1.48457495259449178E-03,
     8 1.44732339830617591E-03, 1.30268261285657186E-03,
     9 1.10351597375642682E-03, 8.86047440419791759E-04,
     A 6.73073208165665473E-04, 4.77603872856582378E-04,
     B 3.05991926358789362E-04, 1.60315694594721630E-04,
     C 4.00749555270613286E-05, -5.66607461635251611E-05,
     D -1.32506186772982638E-04, -1.90296187989614057E-04/
      DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175),
     1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180),
     2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185),
     3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/
     4 -2.32811450376937408E-04, -2.62628811464668841E-04,
     5 -2.82050469867598672E-04, -2.93081563192861167E-04,
     6 -2.97435962176316616E-04, -2.96557334239348078E-04,
     7 -2.91647363312090861E-04, -2.83696203837734166E-04,
     8 -2.73512317095673346E-04, -2.61750155806768580E-04,
     9 6.38585891212050914E-03, 9.62374215806377941E-03,
     A 7.61878061207001043E-03, 2.83219055545628054E-03,
     B -2.09841352012720090E-03, -5.73826764216626498E-03,
     C -7.70804244495414620E-03, -8.21011692264844401E-03,
     D -7.65824520346905413E-03, -6.47209729391045177E-03/
      DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195),
     1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200),
     2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205),
     3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/
     4 -4.99132412004966473E-03, -3.45612289713133280E-03,
     5 -2.01785580014170775E-03, -7.59430686781961401E-04,
     6 2.84173631523859138E-04, 1.10891667586337403E-03,
     7 1.72901493872728771E-03, 2.16812590802684701E-03,
     8 2.45357710494539735E-03, 2.61281821058334862E-03,
     9 2.67141039656276912E-03, 2.65203073395980430E-03,
     A 2.57411652877287315E-03, 2.45389126236094427E-03,
     B 2.30460058071795494E-03, 2.13684837686712662E-03,
     C 1.95896528478870911E-03, 1.77737008679454412E-03,
     D 1.59690280765839059E-03, 1.42111975664438546E-03/
      DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6),
     1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12),
     2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18),
     3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/
     4 6.29960524947436582E-01, 2.51984209978974633E-01,
     5 1.54790300415655846E-01, 1.10713062416159013E-01,
     6 8.57309395527394825E-02, 6.97161316958684292E-02,
     7 5.86085671893713576E-02, 5.04698873536310685E-02,
     8 4.42600580689154809E-02, 3.93720661543509966E-02,
     9 3.54283195924455368E-02, 3.21818857502098231E-02,
     A 2.94646240791157679E-02, 2.71581677112934479E-02,
     B 2.51768272973861779E-02, 2.34570755306078891E-02,
     C 2.19508390134907203E-02, 2.06210828235646240E-02,
     D 1.94388240897880846E-02, 1.83810633800683158E-02,
     E 1.74293213231963172E-02, 1.65685837786612353E-02/
      DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28),
     1 GAMA(29), GAMA(30)/
     2 1.57865285987918445E-02, 1.50729501494095594E-02,
     3 1.44193250839954639E-02, 1.38184805735341786E-02,
     4 1.32643378994276568E-02, 1.27517121970498651E-02,
     5 1.22761545318762767E-02, 1.18338262398482403E-02/
      DATA EX1, EX2, HPI, PI, THPI /
     1 3.33333333333333333E-01, 6.66666666666666667E-01,
     2 1.57079632679489662E+00, 3.14159265358979324E+00,
     3 4.71238898038468986E+00/
      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
C
      RFNU = 1.0E0/FNU
C ZB = Z*DCMPLX(RFNU,0.0E0)
      ZB = Z*RFNU
      RFNU2 = RFNU*RFNU
C-----------------------------------------------------------------------
C COMPUTE IN THE FOURTH QUADRANT
C-----------------------------------------------------------------------
      FN13 = FNU**EX1
      FN23 = FN13*FN13
C RFN13 = DCMPLX(1.0E0/FN13,0.0E0)
      RFN13 = 1.0E0/FN13
      W2 = CONE - ZB*ZB
      AW2 = ZABS(W2)
      IF (AW2.GT.0.25E0) GO TO 130
C-----------------------------------------------------------------------
C POWER SERIES FOR ZABS(W2).LE.0.25E0
C-----------------------------------------------------------------------
      K = 1
      P(1) = CONE
C SUMA = DCMPLX(GAMA(1),0.0E0)
      SUMA = GAMA(1)
      AP(1) = 1.0E0
      IF (AW2.LT.TOL) GO TO 20
      DO 10 K=2,30
        P(K) = P(K-1)*W2
C SUMA = SUMA + P(K)*DCMPLX(GAMA(K),0.0E0)
        SUMA = SUMA + P(K)*GAMA(K)
        AP(K) = AP(K-1)*AW2
        IF (AP(K).LT.TOL) GO TO 20
   10 CONTINUE
      K = 30
   20 CONTINUE
      KMAX = K
      ZETA = W2*SUMA
C ARG = ZETA*DCMPLX(FN23,0.0E0)
      ARG = ZETA*FN23
      ZA = ZSQRT(SUMA)
C ZETA2 = ZSQRT(W2)*DCMPLX(FNU,0.0E0)
C ZETA1 = ZETA2*(CONE+ZETA*ZA*DCMPLX(EX2,0.0E0))
      ZETA2 = ZSQRT(W2)*FNU
      ZETA1 = ZETA2*(CONE+ZETA*ZA*EX2)
      ZA = ZA + ZA
      PHI = ZSQRT(ZA)*RFN13
      IF (IPMTR.EQ.1) GO TO 120
C-----------------------------------------------------------------------
C SUM SERIES FOR ASUM AND BSUM
C-----------------------------------------------------------------------
      SUMB = CZERO
      DO 30 K=1,KMAX
C SUMB = SUMB + P(K)*DCMPLX(BETA(K),0.0E0)
        SUMB = SUMB + P(K)*BETA(K)
   30 CONTINUE
      ASUM = CZERO
      BSUM = SUMB
      L1 = 0
      L2 = 30
      BTOL = TOL*ZABS(BSUM)
      ATOL = TOL
      PP = 1.0E0
      IAS = 0
      IBS = 0
      IF (RFNU2.LT.TOL) GO TO 110
      DO 100 IS=2,7
        ATOL = ATOL/RFNU2
        PP = PP*RFNU2
        IF (IAS.EQ.1) GO TO 60
        SUMA = CZERO
        DO 40 K=1,KMAX
          M = L1 + K
C SUMA = SUMA + P(K)*DCMPLX(ALFA(M),0.0E0)
          SUMA = SUMA + P(K)*ALFA(M)
          IF (AP(K).LT.ATOL) GO TO 50
   40 CONTINUE
   50 CONTINUE
C ASUM = ASUM + SUMA*DCMPLX(PP,0.0E0)
        ASUM = ASUM + SUMA*PP
        IF (PP.LT.TOL) IAS = 1
   60 CONTINUE
        IF (IBS.EQ.1) GO TO 90
        SUMB = CZERO
        DO 70 K=1,KMAX
          M = L2 + K
C SUMB = SUMB + P(K)*DCMPLX(BETA(M),0.0E0)
          SUMB = SUMB + P(K)*BETA(M)
          IF (AP(K).LT.ATOL) GO TO 80
   70 CONTINUE
   80 CONTINUE
C BSUM = BSUM + SUMB*DCMPLX(PP,0.0E0)
        BSUM = BSUM + SUMB*PP
        IF (PP.LT.BTOL) IBS = 1
   90 CONTINUE
        IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110
        L1 = L1 + 30
        L2 = L2 + 30
  100 CONTINUE
  110 CONTINUE
      ASUM = ASUM + CONE
      PP = RFNU*DBLE(RFN13)
C BSUM = BSUM*DCMPLX(PP,0.0E0)
      BSUM = BSUM*PP
  120 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C ZABS(W2).GT.0.25E0
C-----------------------------------------------------------------------
  130 CONTINUE
      W = ZSQRT(W2)
      WR = DBLE(W)
      WI = DIMAG(W)
      IF (WR.LT.0.0E0) WR = 0.0E0
      IF (WI.LT.0.0E0) WI = 0.0E0
      W = DCMPLX(WR,WI)
      ZA = (CONE+W)/ZB
      ZC = ZLOG(ZA)
      ZCR = DBLE(ZC)
      ZCI = DIMAG(ZC)
      IF (ZCI.LT.0.0E0) ZCI = 0.0E0
      IF (ZCI.GT.HPI) ZCI = HPI
      IF (ZCR.LT.0.0E0) ZCR = 0.0E0
      ZC = DCMPLX(ZCR,ZCI)
C ZTH = (ZC-W)*DCMPLX(1.5E0,0.0E0)
C CFNU = DCMPLX(FNU,0.0E0)
      ZTH = (ZC-W)*1.5
      CFNU = FNU
      ZETA1 = ZC*CFNU
      ZETA2 = W*CFNU
      AZTH = ZABS(ZTH)
      ZTHR = DBLE(ZTH)
      ZTHI = DIMAG(ZTH)
      ANG = THPI
      IF (ZTHR.GE.0.0E0 .AND. ZTHI.LT.0.0E0) GO TO 140
      ANG = HPI
      IF (ZTHR.EQ.0.0E0) GO TO 140
      ANG = ATAN(ZTHI/ZTHR)
      IF (ZTHR.LT.0.0E0) ANG = ANG + PI
  140 CONTINUE
      PP = AZTH**EX2
      ANG = ANG*EX2
      ZETAR = PP*COS(ANG)
      ZETAI = PP*SIN(ANG)
      IF (ZETAI.LT.0.0E0) ZETAI = 0.0E0
      ZETA = DCMPLX(ZETAR,ZETAI)
C ARG = ZETA*DCMPLX(FN23,0.0E0)
      ARG = ZETA*FN23
      RTZTA = ZTH/ZETA
      ZA = RTZTA/W
      PHI = ZSQRT(ZA+ZA)*RFN13
      IF (IPMTR.EQ.1) GO TO 120
C TFN = DCMPLX(RFNU,0.0E0)/W
C RZTH = DCMPLX(RFNU,0.0E0)/ZTH
C ZC = RZTH*DCMPLX(AR(2),0.0E0)
      TFN = RFNU/W
      RZTH = RFNU/ZTH
      ZC = RZTH*AR(2)
      T2 = CONE/W2
C UP(2) = (T2*DCMPLX(C(2),0.0E0)+DCMPLX(C(3),0.0E0))*TFN
      UP(2) = (T2*C(2)+C(3))*TFN
      BSUM = UP(2) + ZC
      ASUM = CZERO
      IF (RFNU.LT.TOL) GO TO 220
      PRZTH = RZTH
      PTFN = TFN
      UP(1) = CONE
      PP = 1.0E0
      BSUMR = DBLE(BSUM)
      BSUMI = DIMAG(BSUM)
      BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI))
      KS = 0
      KP1 = 2
      L = 3
      IAS = 0
      IBS = 0
      DO 210 LR=2,12,2
        LRP1 = LR + 1
C-----------------------------------------------------------------------
C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN
C NEXT SUMA AND SUMB
C-----------------------------------------------------------------------
        DO 160 K=LR,LRP1
          KS = KS + 1
          KP1 = KP1 + 1
          L = L + 1
C ZA = DCMPLX(C(L),0.0E0)
          ZA = C(L)
          DO 150 J=2,KP1
            L = L + 1
C ZA = ZA*T2 + DCMPLX(C(L),0.0E0)
            ZA = ZA*T2 + C(L)
  150 CONTINUE
          PTFN = PTFN*TFN
          UP(KP1) = PTFN*ZA
C CR(KS) = PRZTH*DCMPLX(BR(KS+1),0.0E0)
C PRZTH = PRZTH*RZTH
C DR(KS) = PRZTH*DCMPLX(AR(KS+2),0.0E0)
          CR(KS) = PRZTH*BR(KS+1)
          PRZTH = PRZTH*RZTH
          DR(KS) = PRZTH*AR(KS+2)
  160 CONTINUE
        PP = PP*RFNU2
        IF (IAS.EQ.1) GO TO 180
        SUMA = UP(LRP1)
        JU = LRP1
        DO 170 JR=1,LR
          JU = JU - 1
          SUMA = SUMA + CR(JR)*UP(JU)
  170 CONTINUE
        ASUM = ASUM + SUMA
        ASUMR = DBLE(ASUM)
        ASUMI = DIMAG(ASUM)
        TEST = ABS(ASUMR) + ABS(ASUMI)
        IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1
  180 CONTINUE
        IF (IBS.EQ.1) GO TO 200
        SUMB = UP(LR+2) + UP(LRP1)*ZC
        JU = LRP1
        DO 190 JR=1,LR
          JU = JU - 1
          SUMB = SUMB + DR(JR)*UP(JU)
  190 CONTINUE
        BSUM = BSUM + SUMB
        BSUMR = DBLE(BSUM)
        BSUMI = DIMAG(BSUM)
        TEST = ABS(BSUMR) + ABS(BSUMI)
        IF (PP.LT.BTOL .AND. TEST.LT.TOL) IBS = 1
  200 CONTINUE
        IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220
  210 CONTINUE
  220 CONTINUE
      ASUM = ASUM + CONE
      BSUM = -BSUM*RFN13/RTZTA
      GO TO 120
      END
      SUBROUTINE CSERI(Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CSERI
C***REFER TO CBESI,CBESK
C
C CSERI COMPUTES THE I BESSEL FUNCTION FOR DBLE(Z).GE.0.0 BY
C MEANS OF THE POWER SERIES FOR LARGE ZABS(Z) IN THE
C REGION ZABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN.
C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO
C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE
C CONDITION ZABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE
C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ).
C
C***ROUTINES CALLED CUCHK,GAMLN,R1MACH
C***END PROLOGUE CSERI
      DOUBLECOMPLEX
     1 AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, S1, S2, W,
     * Y, Z
      DOUBLEPRECISION
     1 AA, ACZ, AK, ALIM, ARM, ASCLE, ATOL, AZ, DFNU, ELIM, FNU,
     * FNUP, RAK1, RS, RTR1, S, SS, TOL, X, GAMLN, R1MACH
      INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NW, NZ
      DIMENSION Y(*), W(2)
      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
C
      NZ = 0
      AZ = ZABS(Z)
      IF (AZ.EQ.0.0E0) GO TO 150
      X = DBLE(Z)
      ARM = 1.0E+3*R1MACH(1)
      RTR1 = SQRT(ARM)
C CRSC = DCMPLX(1.0E0,0.0E0)
      CRSC = 1.
      IFLAG = 0
      IF (AZ.LT.ARM) GO TO 140
C HZ = Z*DCMPLX(0.5E0,0.0E0)
      HZ = Z / 2
      CZ = CZERO
      IF (AZ.GT.RTR1) CZ = HZ*HZ
      ACZ = ZABS(CZ)
      NN = N
      CK = ZLOG(HZ)
   10 CONTINUE
      DFNU = FNU + FLOAT(NN-1)
      FNUP = DFNU + 1.0E0
C-----------------------------------------------------------------------
C UNDERFLOW TEST
C-----------------------------------------------------------------------
C AK1 = CK*DCMPLX(DFNU,0.0E0)
C AK = GAMLN(FNUP,IDUM)
C AK1 = AK1 - DCMPLX(AK,0.0E0)
C IF (KODE.EQ.2) AK1 = AK1 - DCMPLX(X,0.0E0)
      AK1 = CK*DFNU
      AK = GAMLN(FNUP,IDUM)
      AK1 = AK1 - AK
      IF (KODE.EQ.2) AK1 = AK1 - X
      RAK1 = DBLE(AK1)
      IF (RAK1.GT.(-ELIM)) GO TO 30
   20 CONTINUE
      NZ = NZ + 1
      Y(NN) = CZERO
      IF (ACZ.GT.DFNU) GO TO 170
      NN = NN - 1
      IF (NN.EQ.0) RETURN
      GO TO 10
   30 CONTINUE
      IF (RAK1.GT.(-ALIM)) GO TO 40
      IFLAG = 1
      SS = 1.0E0/TOL
C CRSC = DCMPLX(TOL,0.0E0)
      CRSC = TOL
      ASCLE = ARM*SS
   40 CONTINUE
      AK = DIMAG(AK1)
      AA = EXP(RAK1)
      IF (IFLAG.EQ.1) AA = AA*SS
C COEF = DCMPLX(AA,0.0E0)*DCMPLX(COS(AK),SIN(AK))
      COEF = AA*DCMPLX(COS(AK),SIN(AK))
      ATOL = TOL*ACZ/FNUP
      IL = MIN0(2,NN)
      DO 80 I=1,IL
        DFNU = FNU + FLOAT(NN-I)
        FNUP = DFNU + 1.0E0
        S1 = CONE
        IF (ACZ.LT.TOL*FNUP) GO TO 60
        AK1 = CONE
        AK = FNUP + 2.0E0
        S = FNUP
        AA = 2.0E0
   50 CONTINUE
        RS = 1.0E0/S
C AK1 = AK1*CZ*DCMPLX(RS,0.0E0)
        AK1 = AK1*CZ*RS
        S1 = S1 + AK1
        S = S + AK
        AK = AK + 2.0E0
        AA = AA*ACZ*RS
        IF (AA.GT.ATOL) GO TO 50
   60 CONTINUE
        M = NN - I + 1
        S2 = S1*COEF
        W(I) = S2
        IF (IFLAG.EQ.0) GO TO 70
        CALL CUCHK(S2, NW, ASCLE, TOL)
        IF (NW.NE.0) GO TO 20
   70 CONTINUE
        Y(M) = S2*CRSC
C IF (I.NE.IL) COEF = COEF*DCMPLX(DFNU,0.0E0)/HZ
       IF (I.NE.IL) COEF = COEF*DFNU/HZ
   80 CONTINUE
      IF (NN.LE.2) RETURN
      K = NN - 2
      AK = FLOAT(K)
      RZ = (CONE+CONE)/Z
      IF (IFLAG.EQ.1) GO TO 110
      IB = 3
   90 CONTINUE
      DO 100 I=IB,NN
C Y(K) = DCMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)
        Y(K) = (AK+FNU)*RZ*Y(K+1) + Y(K+2)
        AK = AK - 1.0E0
        K = K - 1
  100 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C RECUR BACKWARD WITH SCALED VALUES
C-----------------------------------------------------------------------
  110 CONTINUE
C-----------------------------------------------------------------------
C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE
C UNDERFLOW LIMIT = ASCLE = R1MACH(1)*CSCL*1.0E+3
C-----------------------------------------------------------------------
      S1 = W(1)
      S2 = W(2)
      DO 120 L=3,NN
        CK = S2
C S2 = S1 + DCMPLX(AK+FNU,0.0E0)*RZ*S2
        S2 = S1 + (AK+FNU)*RZ*S2
        S1 = CK
        CK = S2*CRSC
        Y(K) = CK
        AK = AK - 1.0E0
        K = K - 1
        IF (ZABS(CK).GT.ASCLE) GO TO 130
  120 CONTINUE
      RETURN
  130 CONTINUE
      IB = L + 1
      IF (IB.GT.NN) RETURN
      GO TO 90
  140 CONTINUE
      NZ = N
      IF (FNU.EQ.0.0E0) NZ = NZ - 1
  150 CONTINUE
      Y(1) = CZERO
      IF (FNU.EQ.0.0E0) Y(1) = CONE
      IF (N.EQ.1) RETURN
      DO 160 I=2,N
        Y(I) = CZERO
  160 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C RETURN WITH NZ.LT.0 IF ZABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE
C THE CALCULATION IN CBINU WITH N=N-IABS(NZ)
C-----------------------------------------------------------------------
  170 CONTINUE
      NZ = -NZ
      RETURN
      END
C ***********
      SUBROUTINE CASYI(Z, FNU, KODE, N, Y, NZ, RL, TOL, ELIM, ALIM)
      IMPLICIT CHARACTER*1 (A-Z)
C***BEGIN PROLOGUE CASYI
C***REFER TO CBESI,CBESK
C
C CASYI COMPUTES THE I BESSEL FUNCTION FOR DBLE(Z).GE.0.0 BY
C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ZABS(Z) IN THE
C REGION ZABS(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
      DOUBLECOMPLEX
     1 AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, RZ, S2,
     * Y, Z
      DOUBLEPRECISION
     1 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(*)
      DATA PI, RTPI /3.14159265358979324E0 , 0.159154943091895336E0 /
      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
C
C write (*,*) ' CASYI ..',Z,FNU,KODE,N,Y(1),NZ,RL,TOL,ELIM,ALIM
      NZ = 0
      AZ = ZABS(Z)
      X = DBLE(Z)
      ARM = 1.0E+3*R1MACH(1)
      RTR1 = SQRT(ARM)
      IL = MIN0(2,N)
      DFNU = FNU + FLOAT(N-IL)
C-----------------------------------------------------------------------
C OVERFLOW TEST
C-----------------------------------------------------------------------
C AK1 = DCMPLX(RTPI,0.0E0)/Z
      AK1 = RTPI/Z
      AK1 = ZSQRT(AK1)
      CZ = Z
C IF (KODE.EQ.2) CZ = Z - DCMPLX(X,0.0E0)
      IF (KODE.EQ.2) CZ = Z - X
      ACZ = DBLE(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*ZEXP(CZ)
   10 CONTINUE
      FDN = 0.0E0
      IF (DNU2.GT.RTR1) FDN = DNU2*DNU2
C EZ = Z*DCMPLX(8.0E0,0.0E0)
      EZ = Z*8.
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 = DIMAG(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 = DCMPLX(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
C CK = CK*DCMPLX(SQK,0.0E0)/DK
          CK = CK*SQK/DK
          CS2 = CS2 + CK
          SGN = -SGN
C CS1 = CS1 + CK*DCMPLX(SGN,0.0E0)
          CS1 = CS1 + CK*SGN
          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*ZEXP(-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
C Y(K) = DCMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)
        Y(K) = (AK+FNU)*RZ*Y(K+1) + Y(K+2)
        AK = AK - 1.0E0
        K = K - 1
   60 CONTINUE
      IF (KODED.EQ.0) RETURN
      CK = ZEXP(CZ)
      DO 70 I=1,NN
        Y(I) = Y(I)*CK
   70 CONTINUE
      RETURN
   80 CONTINUE
      NZ = -1
      RETURN
   90 CONTINUE
C write (*,*) ' CASYI: NZ:',-2
      NZ=-2
      RETURN
      END
C ******************
      SUBROUTINE CBUNK(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CBUNK
C***REFER TO CBESK,CBESH
C
C CBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL.
C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z)
C IN CUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN CUNK2
C
C***ROUTINES CALLED CUNK1,CUNK2
C***END PROLOGUE CBUNK
      DOUBLECOMPLEX
     1 Y, Z
      DOUBLEPRECISION
     1 ALIM, AX, AY, ELIM, FNU, TOL, XX, YY
      INTEGER KODE, MR, N, NZ
      DIMENSION Y(*)
      NZ = 0
      XX = DBLE(Z)
      YY = DIMAG(Z)
      AX = ABS(XX)*1.7321E0
      AY = ABS(YY)
      IF (AY.GT.AX) GO TO 10
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN
C -PI/3.LE.ARG(Z).LE.PI/3
C-----------------------------------------------------------------------
      CALL CUNK1(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM)
      GO TO 20
   10 CONTINUE
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU
C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
C AND HPI=PI/2
C-----------------------------------------------------------------------
      CALL CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM)
   20 CONTINUE
      RETURN
      END
C **************
      SUBROUTINE CUNK1(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CUNK1
C***REFER TO CBESK
C
C CUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
C UNIFORM ASYMPTOTIC EXPANSION.
C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
C NZ=-1 MEANS AN OVERFLOW WILL OCCUR
C
C***ROUTINES CALLED CS1S2,CUCHK,CUNIK,R1MACH
C***END PROLOGUE CUNK1
      INTEGER M
      DOUBLECOMPLEX
     1 CFN, CK, CONE, CRSC, CS, CSCL, CSGN, CSPN, CSR, CSS,
     * CWRK, CY, CZERO, C1, C2, PHI, RZ, SUM, S1, S2, Y, Z,
     * ZETA1, ZETA2, ZR, PHID, ZETA1D, ZETA2D, SUMD
      DOUBLEPRECISION
     1 ALIM, ANG, APHI, ASC, ASCLE, BRY, CPN, C2I, C2M, C2R, ELIM,
     * FMR, FN, FNF, FNU, PI, RS1, SGN, SPN, TOL, X, R1MACH
      INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG,
     * KK, KODE, MR, N, NW, NZ, J, IPARD, INITD, IC
      DIMENSION BRY(3), INIT(2), Y(*), SUM(2), PHI(2), ZETA1(2),
     * ZETA2(2), CY(2), CWRK(16,3), CSS(3), CSR(3)
      DATA CZERO, CONE / (0.0E0,0.0E0) , (1.0E0,0.0E0) /
      DATA PI / 3.14159265358979324E0 /
C
      KDFLG = 1
      NZ = 0
C-----------------------------------------------------------------------
C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
C THE UNDERFLOW LIMIT
C-----------------------------------------------------------------------
C CSCL = DCMPLX(1.0E0/TOL,0.0E0)
C CRSC = DCMPLX(TOL,0.0E0)
      CSCL = 1./TOL
      CRSC = TOL
      CSS(1) = CSCL
      CSS(2) = CONE
      CSS(3) = CRSC
      CSR(1) = CRSC
      CSR(2) = CONE
      CSR(3) = CSCL
      BRY(1) = 1.0E+3*R1MACH(1)/TOL
      BRY(2) = 1.0E0/BRY(1)
      BRY(3) = R1MACH(2)
      X = DBLE(Z)
      ZR = Z
      IF (X.LT.0.0E0) ZR = -Z
      J=2
      DO 70 I=1,N
C-----------------------------------------------------------------------
C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
C-----------------------------------------------------------------------
        J = 3 - J
        FN = FNU + FLOAT(I-1)
        INIT(J) = 0
        CALL CUNIK(ZR, FN, 2, 0, TOL, INIT(J), PHI(J), ZETA1(J),
     * ZETA2(J), SUM(J), CWRK(1,J))
        IF (KODE.EQ.1) GO TO 20
C CFN = DCMPLX(FN,0.0E0)
        CFN = FN
        S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J)))
        GO TO 30
   20 CONTINUE
        S1 = ZETA1(J) - ZETA2(J)
   30 CONTINUE
C-----------------------------------------------------------------------
C TEST FOR UNDERFLOW AND OVERFLOW
C-----------------------------------------------------------------------
        RS1 = DBLE(S1)
        IF (ABS(RS1).GT.ELIM) GO TO 60
        IF (KDFLG.EQ.1) KFLAG = 2
        IF (ABS(RS1).LT.ALIM) GO TO 40
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
        APHI = ZABS(PHI(J))
        RS1 = RS1 + DLOG(APHI)
        IF (ABS(RS1).GT.ELIM) GO TO 60
        IF (KDFLG.EQ.1) KFLAG = 1
        IF (RS1.LT.0.0E0) GO TO 40
        IF (KDFLG.EQ.1) KFLAG = 3
   40 CONTINUE
C-----------------------------------------------------------------------
C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
C EXPONENT EXTREMES
C-----------------------------------------------------------------------
        S2 = PHI(J)*SUM(J)
        C2R = DBLE(S1)
        C2I = DIMAG(S1)
        C2M = EXP(C2R)*DBLE(CSS(KFLAG))
C S1 = DCMPLX(C2M,0.0E0)*DCMPLX(COS(C2I),SIN(C2I))
        S1 = C2M*DCMPLX(COS(C2I),SIN(C2I))
        S2 = S2*S1
        IF (KFLAG.NE.1) GO TO 50
        CALL CUCHK(S2, NW, BRY(1), TOL)
        IF (NW.NE.0) GO TO 60
   50 CONTINUE
        CY(KDFLG) = S2
        Y(I) = S2*CSR(KFLAG)
        IF (KDFLG.EQ.2) GO TO 75
        KDFLG = 2
        GO TO 70
   60 CONTINUE
        IF (RS1.GT.0.0E0) GO TO 290
C-----------------------------------------------------------------------
C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
C-----------------------------------------------------------------------
        IF (X.LT.0.0E0) GO TO 290
        KDFLG = 1
        Y(I) = CZERO
        NZ=NZ+1
        IF (I.EQ.1) GO TO 70
        IF (Y(I-1).EQ.CZERO) GO TO 70
        Y(I-1) = CZERO
        NZ=NZ+1
   70 CONTINUE
      I=N
   75 CONTINUE
C RZ = DCMPLX(2.0E0,0.0E0)/ZR
C CK = DCMPLX(FN,0.0E0)*RZ
      RZ = 2./ZR
      CK = FN*RZ
      IB = I+1
      IF (N.LT.IB) GO TO 160
C-----------------------------------------------------------------------
C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO
C ON UNDERFLOW
C-----------------------------------------------------------------------
      FN = FNU+FLOAT(N-1)
      IPARD = 1
      IF (MR.NE.0) IPARD = 0
      INITD = 0
      CALL CUNIK(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD,
     *CWRK(1,3))
      IF (KODE.EQ.1) GO TO 80
C CFN=DCMPLX(FN,0.0E0)
      CFN=FN
      S1=ZETA1D-CFN*(CFN/(ZR+ZETA2D))
      GO TO 90
   80 CONTINUE
      S1=ZETA1D-ZETA2D
   90 CONTINUE
      RS1=DBLE(S1)
      IF (ABS(RS1).GT.ELIM) GO TO 95
      IF (ABS(RS1).LT.ALIM) GO TO 100
C-----------------------------------------------------------------------
C REFINE ESTIMATE AND TEST
C-----------------------------------------------------------------------
      APHI=ZABS(PHID)
      RS1=RS1+DLOG(APHI)
      IF (ABS(RS1).LT.ELIM) GO TO 100
   95 CONTINUE
      IF (RS1.GT.0.0E0) GO TO 290
C-----------------------------------------------------------------------
C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
C-----------------------------------------------------------------------
      IF (X.LT.0.0E0) GO TO 290
      NZ=N
      DO 96 I=1,N
        Y(I) = CZERO
   96 CONTINUE
      RETURN
  100 CONTINUE
C-----------------------------------------------------------------------
C RECUR FORWARD FOR REMAINDER OF THE SEQUENCE
C-----------------------------------------------------------------------
      S1 = CY(1)
      S2 = CY(2)
      C1 = CSR(KFLAG)
      ASCLE = BRY(KFLAG)
      DO 120 I=IB,N
        C2 = S2
        S2 = CK*S2 + S1
        S1 = C2
        CK = CK + RZ
        C2 = S2*C1
        Y(I) = C2
        IF (KFLAG.GE.3) GO TO 120
        C2R = DBLE(C2)
        C2I = DIMAG(C2)
        C2R = ABS(C2R)
        C2I = ABS(C2I)
        C2M = DMAX1(C2R,C2I)
        IF (C2M.LE.ASCLE) GO TO 120
        KFLAG = KFLAG + 1
        ASCLE = BRY(KFLAG)
        S1 = S1*C1
        S2 = C2
        S1 = S1*CSS(KFLAG)
        S2 = S2*CSS(KFLAG)
        C1 = CSR(KFLAG)
  120 CONTINUE
  160 CONTINUE
      IF (MR.EQ.0) RETURN
C-----------------------------------------------------------------------
C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0
C-----------------------------------------------------------------------
      NZ = 0
      FMR = FLOAT(MR)
      SGN = -SIGN(PI,FMR)
C-----------------------------------------------------------------------
C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP.
C-----------------------------------------------------------------------
C CSGN = DCMPLX(0.0E0,SGN)
      CSGN = (0.,1.)*SGN
      INU = INT(FNU)
      FNF = FNU - FLOAT(INU)
      IFN = INU + N - 1
      ANG = FNF*SGN
      CPN = COS(ANG)
      SPN = SIN(ANG)
      CSPN = DCMPLX(CPN,SPN)
      IF (MOD(IFN,2).EQ.1) CSPN = -CSPN
      ASC = BRY(1)
      KK = N
      IUF = 0
      KDFLG = 1
      IB = IB-1
      IC = IB-1
      DO 260 K=1,N
        FN = FNU + FLOAT(KK-1)
C-----------------------------------------------------------------------
C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
C FUNCTION ABOVE
C-----------------------------------------------------------------------
        M=3
        IF (N.GT.2) GO TO 175
  170 CONTINUE
        INITD = INIT(J)
        PHID = PHI(J)
        ZETA1D = ZETA1(J)
        ZETA2D = ZETA2(J)
        SUMD = SUM(J)
        M = J
        J = 3 - J
        GO TO 180
  175 CONTINUE
        IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180
        IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 170
        INITD = 0
  180 CONTINUE
        CALL CUNIK(ZR, FN, 1, 0, TOL, INITD, PHID, ZETA1D,
     * ZETA2D, SUMD, CWRK(1,M))
        IF (KODE.EQ.1) GO TO 190
C CFN = DCMPLX(FN,0.0E0)
        CFN = FN
        S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D))
        GO TO 200
  190 CONTINUE
        S1 = -ZETA1D + ZETA2D
  200 CONTINUE
C-----------------------------------------------------------------------
C TEST FOR UNDERFLOW AND OVERFLOW
C-----------------------------------------------------------------------
        RS1 = DBLE(S1)
        IF (ABS(RS1).GT.ELIM) GO TO 250
        IF (KDFLG.EQ.1) IFLAG = 2
        IF (ABS(RS1).LT.ALIM) GO TO 210
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
        APHI = ZABS(PHID)
        RS1 = RS1 + DLOG(APHI)
        IF (ABS(RS1).GT.ELIM) GO TO 250
        IF (KDFLG.EQ.1) IFLAG = 1
        IF (RS1.LT.0.0E0) GO TO 210
        IF (KDFLG.EQ.1) IFLAG = 3
  210 CONTINUE
        S2 = CSGN*PHID*SUMD
        C2R = DBLE(S1)
        C2I = DIMAG(S1)
        C2M = EXP(C2R)*DBLE(CSS(IFLAG))
C S1 = DCMPLX(C2M,0.0E0)*DCMPLX(COS(C2I),SIN(C2I))
        S1 = C2M*DCMPLX(COS(C2I),SIN(C2I))
        S2 = S2*S1
        IF (IFLAG.NE.1) GO TO 220
        CALL CUCHK(S2, NW, BRY(1), TOL)
C IF (NW.NE.0) S2 = DCMPLX(0.0E0,0.0E0)
        IF (NW.NE.0) S2 = 0.
  220 CONTINUE
        CY(KDFLG) = S2
        C2 = S2
        S2 = S2*CSR(IFLAG)
C-----------------------------------------------------------------------
C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
C-----------------------------------------------------------------------
        S1 = Y(KK)
        IF (KODE.EQ.1) GO TO 240
        CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF)
        NZ = NZ + NW
  240 CONTINUE
        Y(KK) = S1*CSPN + S2
        KK = KK - 1
        CSPN = -CSPN
        IF (C2.NE.CZERO) GO TO 245
        KDFLG = 1
        GO TO 260
  245 CONTINUE
        IF (KDFLG.EQ.2) GO TO 265
        KDFLG = 2
        GO TO 260
  250 CONTINUE
        IF (RS1.GT.0.0E0) GO TO 290
        S2 = CZERO
        GO TO 220
  260 CONTINUE
      K = N
  265 CONTINUE
      IL = N - K
      IF (IL.EQ.0) RETURN
C-----------------------------------------------------------------------
C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
C-----------------------------------------------------------------------
      S1 = CY(1)
      S2 = CY(2)
      CS = CSR(IFLAG)
      ASCLE = BRY(IFLAG)
      FN = FLOAT(INU+IL)
      DO 280 I=1,IL
        C2 = S2
C S2 = S1 + DCMPLX(FN+FNF,0.0E0)*RZ*S2
        S2 = S1 + (FN+FNF)*RZ*S2
        S1 = C2
        FN = FN - 1.0E0
        C2 = S2*CS
        CK = C2
        C1 = Y(KK)
        IF (KODE.EQ.1) GO TO 270
        CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF)
        NZ = NZ + NW
  270 CONTINUE
        Y(KK) = C1*CSPN + C2
        KK = KK - 1
        CSPN = -CSPN
        IF (IFLAG.GE.3) GO TO 280
        C2R = DBLE(CK)
        C2I = DIMAG(CK)
        C2R = ABS(C2R)
        C2I = ABS(C2I)
        C2M = DMAX1(C2R,C2I)
        IF (C2M.LE.ASCLE) GO TO 280
        IFLAG = IFLAG + 1
        ASCLE = BRY(IFLAG)
        S1 = S1*CS
        S2 = CK
        S1 = S1*CSS(IFLAG)
        S2 = S2*CSS(IFLAG)
        CS = CSR(IFLAG)
  280 CONTINUE
      RETURN
  290 CONTINUE
      NZ = -1
      RETURN
      END
      SUBROUTINE CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CUNK2
C***REFER TO CBESK
C
C CUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN)
C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR
C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT
C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC-
C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
C NZ=-1 MEANS AN OVERFLOW WILL OCCUR
C
C***ROUTINES CALLED CAIRY,CS1S2,CUCHK,CUNHJ,R1MACH
C***END PROLOGUE CUNK2
      DOUBLECOMPLEX
     1 AI, ARG, ASUM, BSUM, CFN, CI, CIP,
     * CK, CONE, CRSC, CR1, CR2, CS, CSCL, CSGN, CSPN, CSR, CSS, CY,
     * CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, ZETA1,
     * ZETA2, ZN, ZR, PHID, ARGD, ZETA1D, ZETA2D, ASUMD, BSUMD
      DOUBLEPRECISION
     1 AARG, AIC, ALIM, ANG, APHI, ASC, ASCLE, BRY, CAR, CPN, C2I,
     * C2M, C2R, ELIM, FMR, FN, FNF, FNU, HPI, PI, RS1, SAR, SGN, SPN,
     * TOL, X, YY, R1MACH
      INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK,
     * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC
      DIMENSION BRY(3), Y(*), ASUM(2), BSUM(2), PHI(2), ARG(2),
     * ZETA1(2), ZETA2(2), CY(2), CIP(4), CSS(3), CSR(3)
      DATA CZERO, CONE, CI, CR1, CR2 /
     1 (0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0),
     1(1.0E0,1.73205080756887729E0),(-0.5E0,-8.66025403784438647E-01)/
      DATA HPI, PI, AIC /
     1 1.57079632679489662E+00, 3.14159265358979324E+00,
     1 1.26551212348464539E+00/
      DATA CIP(1),CIP(2),CIP(3),CIP(4)/
     1 (1.0E0,0.0E0), (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/
C
      KDFLG = 1
      NZ = 0
C-----------------------------------------------------------------------
C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
C THE UNDERFLOW LIMIT
C-----------------------------------------------------------------------
C CSCL = DCMPLX(1.0E0/TOL,0.0E0)
C CRSC = DCMPLX(TOL,0.0E0)
      CSCL = 1./TOL
      CRSC = TOL
      CSS(1) = CSCL
      CSS(2) = CONE
      CSS(3) = CRSC
      CSR(1) = CRSC
      CSR(2) = CONE
      CSR(3) = CSCL
      BRY(1) = 1.0E+3*R1MACH(1)/TOL
      BRY(2) = 1.0E0/BRY(1)
      BRY(3) = R1MACH(2)
      X = DBLE(Z)
      ZR = Z
      IF (X.LT.0.0E0) ZR = -Z
      YY = DIMAG(ZR)
      ZN = -ZR*CI
      ZB = ZR
      INU = INT(FNU)
      FNF = FNU - FLOAT(INU)
      ANG = -HPI*FNF
      CAR = COS(ANG)
      SAR = SIN(ANG)
      CPN = -HPI*CAR
      SPN = -HPI*SAR
      C2 = DCMPLX(-SPN,CPN)
      KK = MOD(INU,4) + 1
      CS = CR1*C2*CIP(KK)
      IF (YY.GT.0.0E0) GO TO 10
      ZN = DCONJG(-ZN)
      ZB = DCONJG(ZB)
   10 CONTINUE
C-----------------------------------------------------------------------
C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST
C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
C CONJUGATION SINCE THE K FUNCTION IS DOUBLEPRECISION ON THE POSITIVE DOUBLEPRECISION AXIS
C-----------------------------------------------------------------------
      J = 2
      DO 70 I=1,N
C-----------------------------------------------------------------------
C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
C-----------------------------------------------------------------------
        J = 3 - J
        FN = FNU + FLOAT(I-1)
        CALL CUNHJ(ZN, FN, 0, TOL, PHI(J), ARG(J), ZETA1(J), ZETA2(J),
     * ASUM(J), BSUM(J))
        IF (KODE.EQ.1) GO TO 20
C CFN = DCMPLX(FN,0.0E0)
        CFN = FN
        S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J)))
        GO TO 30
   20 CONTINUE
        S1 = ZETA1(J) - ZETA2(J)
   30 CONTINUE
C-----------------------------------------------------------------------
C TEST FOR UNDERFLOW AND OVERFLOW
C-----------------------------------------------------------------------
        RS1 = DBLE(S1)
        IF (ABS(RS1).GT.ELIM) GO TO 60
        IF (KDFLG.EQ.1) KFLAG = 2
        IF (ABS(RS1).LT.ALIM) GO TO 40
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
        APHI = ZABS(PHI(J))
        AARG = ZABS(ARG(J))
        RS1 = RS1 + DLOG(APHI) - 0.25E0*DLOG(AARG) - AIC
        IF (ABS(RS1).GT.ELIM) GO TO 60
        IF (KDFLG.EQ.1) KFLAG = 1
        IF (RS1.LT.0.0E0) GO TO 40
        IF (KDFLG.EQ.1) KFLAG = 3
   40 CONTINUE
C-----------------------------------------------------------------------
C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
C EXPONENT EXTREMES
C-----------------------------------------------------------------------
        C2 = ARG(J)*CR2
        CALL CAIRY(C2, 0, 2, AI, NAI, IDUM)
        CALL CAIRY(C2, 1, 2, DAI, NDAI, IDUM)
        S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J))
        C2R = DBLE(S1)
        C2I = DIMAG(S1)
        C2M = EXP(C2R)*DBLE(CSS(KFLAG))
C S1 = DCMPLX(C2M,0.0E0)*DCMPLX(COS(C2I),SIN(C2I))
        S1 = C2M*DCMPLX(COS(C2I),SIN(C2I))
        S2 = S2*S1
        IF (KFLAG.NE.1) GO TO 50
        CALL CUCHK(S2, NW, BRY(1), TOL)
        IF (NW.NE.0) GO TO 60
   50 CONTINUE
        IF (YY.LE.0.0E0) S2 = DCONJG(S2)
        CY(KDFLG) = S2
        Y(I) = S2*CSR(KFLAG)
        CS = -CI*CS
        IF (KDFLG.EQ.2) GO TO 75
        KDFLG = 2
        GO TO 70
   60 CONTINUE
        IF (RS1.GT.0.0E0) GO TO 300
C-----------------------------------------------------------------------
C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
C-----------------------------------------------------------------------
        IF (X.LT.0.0E0) GO TO 300
        KDFLG = 1
        Y(I) = CZERO
        CS = -CI*CS
        NZ=NZ+1
        IF (I.EQ.1) GO TO 70
        IF (Y(I-1).EQ.CZERO) GO TO 70
        Y(I-1) = CZERO
        NZ=NZ+1
   70 CONTINUE
      I=N
   75 CONTINUE
C RZ = DCMPLX(2.0E0,0.0E0)/ZR
C CK = DCMPLX(FN,0.0E0)*RZ
      RZ = 2./ZR
      CK = FN*RZ
      IB = I + 1
      IF (N.LT.IB) GO TO 170
C-----------------------------------------------------------------------
C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO
C ON UNDERFLOW
C-----------------------------------------------------------------------
      FN = FNU+FLOAT(N-1)
      IPARD = 1
      IF (MR.NE.0) IPARD = 0
      CALL CUNHJ(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD,BSUMD)
      IF (KODE.EQ.1) GO TO 80
C CFN=DCMPLX(FN,0.0E0)
      CFN= FN
      S1=ZETA1D-CFN*(CFN/(ZB+ZETA2D))
      GO TO 90
   80 CONTINUE
      S1=ZETA1D-ZETA2D
   90 CONTINUE
      RS1=DBLE(S1)
      IF (ABS(RS1).GT.ELIM) GO TO 95
      IF (ABS(RS1).LT.ALIM) GO TO 100
C-----------------------------------------------------------------------
C REFINE ESTIMATE AND TEST
C-----------------------------------------------------------------------
      APHI=ZABS(PHID)
      AARG = ZABS(ARGD)
      RS1=RS1+DLOG(APHI)-0.25E0*DLOG(AARG)-AIC
      IF (ABS(RS1).LT.ELIM) GO TO 100
   95 CONTINUE
      IF (RS1.GT.0.0E0) GO TO 300
C-----------------------------------------------------------------------
C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
C-----------------------------------------------------------------------
      IF (X.LT.0.0E0) GO TO 300
      NZ=N
      DO 96 I=1,N
        Y(I) = CZERO
   96 CONTINUE
      RETURN
  100 CONTINUE
C-----------------------------------------------------------------------
C SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE
C-----------------------------------------------------------------------
      S1 = CY(1)
      S2 = CY(2)
      C1 = CSR(KFLAG)
      ASCLE = BRY(KFLAG)
      DO 120 I=IB,N
        C2 = S2
        S2 = CK*S2 + S1
        S1 = C2
        CK = CK + RZ
        C2 = S2*C1
        Y(I) = C2
        IF (KFLAG.GE.3) GO TO 120
        C2R = DBLE(C2)
        C2I = DIMAG(C2)
        C2R = ABS(C2R)
        C2I = ABS(C2I)
        C2M = DMAX1(C2R,C2I)
        IF (C2M.LE.ASCLE) GO TO 120
        KFLAG = KFLAG + 1
        ASCLE = BRY(KFLAG)
        S1 = S1*C1
        S2 = C2
        S1 = S1*CSS(KFLAG)
        S2 = S2*CSS(KFLAG)
        C1 = CSR(KFLAG)
  120 CONTINUE
  170 CONTINUE
      IF (MR.EQ.0) RETURN
C-----------------------------------------------------------------------
C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0
C-----------------------------------------------------------------------
      NZ = 0
      FMR = FLOAT(MR)
      SGN = -SIGN(PI,FMR)
C-----------------------------------------------------------------------
C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
C-----------------------------------------------------------------------
C CSGN = DCMPLX(0.0E0,SGN)
      CSGN = (0.,1.)*SGN
      IF (YY.LE.0.0E0) CSGN = DCONJG(CSGN)
      IFN = INU + N - 1
      ANG = FNF*SGN
      CPN = COS(ANG)
      SPN = SIN(ANG)
      CSPN = DCMPLX(CPN,SPN)
      IF (MOD(IFN,2).EQ.1) CSPN = -CSPN
C-----------------------------------------------------------------------
C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS
C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST
C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
C CONJUGATION SINCE THE I FUNCTION IS DOUBLEPRECISION ON THE POSITIVE DOUBLEPRECISION AXIS
C-----------------------------------------------------------------------
      CS = DCMPLX(CAR,-SAR)*CSGN
      IN = MOD(IFN,4) + 1
      C2 = CIP(IN)
      CS = CS*DCONJG(C2)
      ASC = BRY(1)
      KK = N
      KDFLG = 1
      IB = IB-1
      IC = IB-1
      IUF = 0
      DO 270 K=1,N
C-----------------------------------------------------------------------
C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
C FUNCTION ABOVE
C-----------------------------------------------------------------------
        FN = FNU+FLOAT(KK-1)
        IF (N.GT.2) GO TO 180
  175 CONTINUE
        PHID = PHI(J)
        ARGD = ARG(J)
        ZETA1D = ZETA1(J)
        ZETA2D = ZETA2(J)
        ASUMD = ASUM(J)
        BSUMD = BSUM(J)
        J = 3 - J
        GO TO 190
  180 CONTINUE
        IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 190
        IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 175
        CALL CUNHJ(ZN, FN, 0, TOL, PHID, ARGD, ZETA1D, ZETA2D,
     * ASUMD, BSUMD)
  190 CONTINUE
        IF (KODE.EQ.1) GO TO 200
C CFN = DCMPLX(FN,0.0E0)
        CFN = FN
        S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D))
        GO TO 210
  200 CONTINUE
        S1 = -ZETA1D + ZETA2D
  210 CONTINUE
C-----------------------------------------------------------------------
C TEST FOR UNDERFLOW AND OVERFLOW
C-----------------------------------------------------------------------
        RS1 = DBLE(S1)
        IF (ABS(RS1).GT.ELIM) GO TO 260
        IF (KDFLG.EQ.1) IFLAG = 2
        IF (ABS(RS1).LT.ALIM) GO TO 220
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
        APHI = ZABS(PHID)
        AARG = ZABS(ARGD)
        RS1 = RS1 + DLOG(APHI) - 0.25E0*DLOG(AARG) - AIC
        IF (ABS(RS1).GT.ELIM) GO TO 260
        IF (KDFLG.EQ.1) IFLAG = 1
        IF (RS1.LT.0.0E0) GO TO 220
        IF (KDFLG.EQ.1) IFLAG = 3
  220 CONTINUE
        CALL CAIRY(ARGD, 0, 2, AI, NAI, IDUM)
        CALL CAIRY(ARGD, 1, 2, DAI, NDAI, IDUM)
        S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD)
        C2R = DBLE(S1)
        C2I = DIMAG(S1)
        C2M = EXP(C2R)*DBLE(CSS(IFLAG))
C S1 = DCMPLX(C2M,0.0E0)*DCMPLX(COS(C2I),SIN(C2I))
        S1 = C2M*DCMPLX(COS(C2I),SIN(C2I))
        S2 = S2*S1
        IF (IFLAG.NE.1) GO TO 230
        CALL CUCHK(S2, NW, BRY(1), TOL)
C IF (NW.NE.0) S2 = DCMPLX(0.0E0,0.0E0)
        IF (NW.NE.0) S2 = 0.
  230 CONTINUE
        IF (YY.LE.0.0E0) S2 = DCONJG(S2)
        CY(KDFLG) = S2
        C2 = S2
        S2 = S2*CSR(IFLAG)
C-----------------------------------------------------------------------
C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
C-----------------------------------------------------------------------
        S1 = Y(KK)
        IF (KODE.EQ.1) GO TO 250
        CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF)
        NZ = NZ + NW
  250 CONTINUE
        Y(KK) = S1*CSPN + S2
        KK = KK - 1
        CSPN = -CSPN
        CS = -CS*CI
        IF (C2.NE.CZERO) GO TO 255
        KDFLG = 1
        GO TO 270
  255 CONTINUE
        IF (KDFLG.EQ.2) GO TO 275
        KDFLG = 2
        GO TO 270
  260 CONTINUE
        IF (RS1.GT.0.0E0) GO TO 300
        S2 = CZERO
        GO TO 230
  270 CONTINUE
      K = N
  275 CONTINUE
      IL = N-K
      IF (IL.EQ.0) RETURN
C-----------------------------------------------------------------------
C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
C-----------------------------------------------------------------------
      S1 = CY(1)
      S2 = CY(2)
      CS = CSR(IFLAG)
      ASCLE = BRY(IFLAG)
      FN = FLOAT(INU+IL)
      DO 290 I=1,IL
        C2 = S2
C S2 = S1 + DCMPLX(FN+FNF,0.0E0)*RZ*S2
        S2 = S1 + (FN+FNF)*RZ*S2
        S1 = C2
        FN = FN - 1.0E0
        C2 = S2*CS
        CK = C2
        C1 = Y(KK)
        IF (KODE.EQ.1) GO TO 280
        CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF)
        NZ = NZ + NW
  280 CONTINUE
        Y(KK) = C1*CSPN + C2
        KK = KK - 1
        CSPN = -CSPN
        IF (IFLAG.GE.3) GO TO 290
        C2R = DBLE(CK)
        C2I = DIMAG(CK)
        C2R = ABS(C2R)
        C2I = ABS(C2I)
        C2M = DMAX1(C2R,C2I)
        IF (C2M.LE.ASCLE) GO TO 290
        IFLAG = IFLAG + 1
        ASCLE = BRY(IFLAG)
        S1 = S1*CS
        S2 = CK
        S1 = S1*CSS(IFLAG)
        S2 = S2*CSS(IFLAG)
        CS = CSR(IFLAG)
  290 CONTINUE
      RETURN
  300 CONTINUE
      NZ = -1
      RETURN
      END
      SUBROUTINE CBUNI(Z, FNU, KODE, N, Y, NZ, NUI, NLAST, FNUL, TOL,
     * ELIM, ALIM)
C***BEGIN PROLOGUE CBUNI
C***REFER TO CBESI,CBESK
C
C CBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE ZABS(Z).GT.
C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM
C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING
C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z)
C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2
C
C***ROUTINES CALLED CUNI1,CUNI2,R1MACH
C***END PROLOGUE CBUNI
      DOUBLECOMPLEX
     1 CSCL, CSCR, CY, RZ, ST, S1, S2, Y, Z
      DOUBLEPRECISION
     1 ALIM, AX, AY, DFNU, ELIM, FNU, FNUI, FNUL, GNU, TOL, XX, YY,
     * ASCLE, BRY, STR, STI, STM, R1MACH
      INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ
      DIMENSION Y(*), CY(2), BRY(3)
      NZ = 0
      XX = DBLE(Z)
      YY = DIMAG(Z)
      AX = ABS(XX)*1.7321E0
      AY = ABS(YY)
      IFORM = 1
      IF (AY.GT.AX) IFORM = 2
      IF (NUI.EQ.0) GO TO 60
      FNUI = FLOAT(NUI)
      DFNU = FNU + FLOAT(N-1)
      GNU = DFNU + FNUI
      IF (IFORM.EQ.2) GO TO 10
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
C -PI/3.LE.ARG(Z).LE.PI/3
C-----------------------------------------------------------------------
      CALL CUNI1(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM)
      GO TO 20
   10 CONTINUE
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
C AND HPI=PI/2
C-----------------------------------------------------------------------
      CALL CUNI2(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM)
   20 CONTINUE
      IF (NW.LT.0) GO TO 50
      IF (NW.NE.0) GO TO 90
      AY = ZABS(CY(1))
C----------------------------------------------------------------------
C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED
C----------------------------------------------------------------------
      BRY(1) = 1.0E+3*R1MACH(1)/TOL
      BRY(2) = 1.0E0/BRY(1)
      BRY(3) = BRY(2)
      IFLAG = 2
      ASCLE = BRY(2)
      AX = 1.0E0
C CSCL = DCMPLX(AX,0.0E0)
      CSCL = AX
      IF (AY.GT.BRY(1)) GO TO 21
      IFLAG = 1
      ASCLE = BRY(1)
      AX = 1.0E0/TOL
C CSCL = DCMPLX(AX,0.0E0)
      CSCL = AX
      GO TO 25
   21 CONTINUE
      IF (AY.LT.BRY(2)) GO TO 25
      IFLAG = 3
      ASCLE = BRY(3)
      AX = TOL
      CSCL = AX
   25 CONTINUE
      AY = 1.0E0/AX
C CSCR = DCMPLX(AY,0.0E0)
      CSCR = AY
      S1 = CY(2)*CSCL
      S2 = CY(1)*CSCL
C RZ = DCMPLX(2.0E0,0.0E0)/Z
      RZ = 2./Z
      DO 30 I=1,NUI
        ST = S2
C S2 = DCMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1
        S2 = (DFNU+FNUI)*RZ*S2 + S1
        S1 = ST
        FNUI = FNUI - 1.0E0
        IF (IFLAG.GE.3) GO TO 30
        ST = S2*CSCR
        STR = DBLE(ST)
        STI = DIMAG(ST)
        STR = ABS(STR)
        STI = ABS(STI)
        STM = DMAX1(STR,STI)
        IF (STM.LE.ASCLE) GO TO 30
        IFLAG = IFLAG+1
        ASCLE = BRY(IFLAG)
        S1 = S1*CSCR
        S2 = ST
        AX = AX*TOL
        AY = 1.0E0/AX
C CSCL = DCMPLX(AX,0.0E0)
C CSCR = DCMPLX(AY,0.0E0)
        CSCL = AX
        CSCR = AY
        S1 = S1*CSCL
        S2 = S2*CSCL
   30 CONTINUE
      Y(N) = S2*CSCR
      IF (N.EQ.1) RETURN
      NL = N - 1
      FNUI = FLOAT(NL)
      K = NL
      DO 40 I=1,NL
        ST = S2
C S2 = DCMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1
        S2 = (FNU+FNUI)*RZ*S2 + S1
        S1 = ST
        ST = S2*CSCR
        Y(K) = ST
        FNUI = FNUI - 1.0E0
        K = K - 1
        IF (IFLAG.GE.3) GO TO 40
        STR = DBLE(ST)
        STI = DIMAG(ST)
        STR = ABS(STR)
        STI = ABS(STI)
        STM = DMAX1(STR,STI)
        IF (STM.LE.ASCLE) GO TO 40
        IFLAG = IFLAG+1
        ASCLE = BRY(IFLAG)
        S1 = S1*CSCR
        S2 = ST
        AX = AX*TOL
        AY = 1.0E0/AX
C CSCL = DCMPLX(AX,0.0E0)
C CSCR = DCMPLX(AY,0.0E0)
        CSCL = AX
        CSCR = AY
        S1 = S1*CSCL
        S2 = S2*CSCL
   40 CONTINUE
      RETURN
   50 CONTINUE
      NZ = -1
      IF(NW.EQ.(-2)) NZ=-2
      RETURN
   60 CONTINUE
      IF (IFORM.EQ.2) GO TO 70
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
C -PI/3.LE.ARG(Z).LE.PI/3
C-----------------------------------------------------------------------
      CALL CUNI1(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM)
      GO TO 80
   70 CONTINUE
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
C AND HPI=PI/2
C-----------------------------------------------------------------------
      CALL CUNI2(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM)
   80 CONTINUE
      IF (NW.LT.0) GO TO 50
      NZ = NW
      RETURN
   90 CONTINUE
      NLAST = N
      RETURN
      END
      SUBROUTINE CUNI2(Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM,
     * ALIM)
C***BEGIN PROLOGUE CUNI2
C***REFER TO CBESI,CBESK
C
C CUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF
C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I
C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO.
C
C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
C Y(I)=CZERO FOR I=NLAST+1,N
C
C***ROUTINES CALLED CAIRY,CUCHK,CUNHJ,CUOIK,R1MACH
C***END PROLOGUE CUNI2
      DOUBLECOMPLEX
     1 AI, ARG, ASUM, BSUM, CFN, CI, CID, CIP, CONE, CRSC, CSCL,
     * CSR, CSS, CY, CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB,
     * ZETA1, ZETA2, ZN
      DOUBLEPRECISION
     1 AARG, AIC, ALIM, ANG, APHI, ASCLE, AY, BRY, CAR, C2I, C2M,
     * C2R, ELIM, FN, FNU, FNUL, HPI, RS1, SAR, TOL, YY, R1MACH
      INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST,
     * NN, NUF, NW, NZ, IDUM
      DIMENSION BRY(3), Y(*), CIP(4), CSS(3), CSR(3), CY(2)
      DATA CZERO,CONE,CI/(0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0)/
      DATA CIP(1),CIP(2),CIP(3),CIP(4)/
     1 (1.0E0,0.0E0), (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/
      DATA HPI, AIC /
     1 1.57079632679489662E+00, 1.265512123484645396E+00/
C
      NZ = 0
      ND = N
      NLAST = 0
C-----------------------------------------------------------------------
C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
C EXP(ALIM)=EXP(ELIM)*TOL
C-----------------------------------------------------------------------
C CSCL = DCMPLX(1.0E0/TOL,0.0E0)
C CRSC = DCMPLX(TOL,0.0E0)
      CSCL = 1./TOL
      CRSC = TOL
      CSS(1) = CSCL
      CSS(2) = CONE
      CSS(3) = CRSC
      CSR(1) = CRSC
      CSR(2) = CONE
      CSR(3) = CSCL
      BRY(1) = 1.0E+3*R1MACH(1)/TOL
      YY = DIMAG(Z)
C-----------------------------------------------------------------------
C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI
C-----------------------------------------------------------------------
      ZN = -Z*CI
      ZB = Z
      CID = -CI
      INU = INT(FNU)
      ANG = HPI*(FNU-FLOAT(INU))
      CAR = COS(ANG)
      SAR = SIN(ANG)
      C2 = DCMPLX(CAR,SAR)
      IN = INU + N - 1
      IN = MOD(IN,4)
      C2 = C2*CIP(IN+1)
      IF (YY.GT.0.0E0) GO TO 10
      ZN = DCONJG(-ZN)
      ZB = DCONJG(ZB)
      CID = -CID
      C2 = DCONJG(C2)
   10 CONTINUE
C-----------------------------------------------------------------------
C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
C-----------------------------------------------------------------------
      FN = DMAX1(FNU,DBLE(1.0E0))
      CALL CUNHJ(ZN, FN, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM)
      IF (KODE.EQ.1) GO TO 20
C CFN = DCMPLX(FNU,0.0E0)
      CFN = FNU
      S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2))
      GO TO 30
   20 CONTINUE
      S1 = -ZETA1 + ZETA2
   30 CONTINUE
      RS1 = DBLE(S1)
      IF (ABS(RS1).GT.ELIM) GO TO 150
   40 CONTINUE
      NN = MIN0(2,ND)
      DO 90 I=1,NN
        FN = FNU + FLOAT(ND-I)
        CALL CUNHJ(ZN, FN, 0, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM)
        IF (KODE.EQ.1) GO TO 50
C CFN = DCMPLX(FN,0.0E0)
        CFN = FN
        AY = ABS(YY)
C S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + DCMPLX(0.0E0,AY)
        S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + (0.,1.)*AY
        GO TO 60
   50 CONTINUE
        S1 = -ZETA1 + ZETA2
   60 CONTINUE
C-----------------------------------------------------------------------
C TEST FOR UNDERFLOW AND OVERFLOW
C-----------------------------------------------------------------------
        RS1 = DBLE(S1)
        IF (ABS(RS1).GT.ELIM) GO TO 120
        IF (I.EQ.1) IFLAG = 2
        IF (ABS(RS1).LT.ALIM) GO TO 70
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
        APHI = ZABS(PHI)
        AARG = ZABS(ARG)
        RS1 = RS1 + DLOG(APHI) - 0.25E0*DLOG(AARG) - AIC
        IF (ABS(RS1).GT.ELIM) GO TO 120
        IF (I.EQ.1) IFLAG = 1
        IF (RS1.LT.0.0E0) GO TO 70
        IF (I.EQ.1) IFLAG = 3
   70 CONTINUE
C-----------------------------------------------------------------------
C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
C EXPONENT EXTREMES
C-----------------------------------------------------------------------
        CALL CAIRY(ARG, 0, 2, AI, NAI, IDUM)
        CALL CAIRY(ARG, 1, 2, DAI, NDAI, IDUM)
        S2 = PHI*(AI*ASUM+DAI*BSUM)
        C2R = DBLE(S1)
        C2I = DIMAG(S1)
        C2M = EXP(C2R)*DBLE(CSS(IFLAG))
C S1 = DCMPLX(C2M,0.0E0)*DCMPLX(COS(C2I),SIN(C2I))
        S1 = C2M*DCMPLX(COS(C2I),SIN(C2I))
        S2 = S2*S1
        IF (IFLAG.NE.1) GO TO 80
        CALL CUCHK(S2, NW, BRY(1), TOL)
        IF (NW.NE.0) GO TO 120
   80 CONTINUE
        IF (YY.LE.0.0E0) S2 = DCONJG(S2)
        J = ND - I + 1
        S2 = S2*C2
        CY(I) = S2
        Y(J) = S2*CSR(IFLAG)
        C2 = C2*CID
   90 CONTINUE
      IF (ND.LE.2) GO TO 110
C RZ = DCMPLX(2.0E0,0.0E0)/Z
      RZ = 2./Z
      BRY(2) = 1.0E0/BRY(1)
      BRY(3) = R1MACH(2)
      S1 = CY(1)
      S2 = CY(2)
      C1 = CSR(IFLAG)
      ASCLE = BRY(IFLAG)
      K = ND - 2
      FN = FLOAT(K)
      DO 100 I=3,ND
        C2 = S2
C S2 = S1 + DCMPLX(FNU+FN,0.0E0)*RZ*S2
        S2 = S1 + (FNU+FN)*RZ*S2
        S1 = C2
        C2 = S2*C1
        Y(K) = C2
        K = K - 1
        FN = FN - 1.0E0
        IF (IFLAG.GE.3) GO TO 100
        C2R = DBLE(C2)
        C2I = DIMAG(C2)
        C2R = ABS(C2R)
        C2I = ABS(C2I)
        C2M = DMAX1(C2R,C2I)
        IF (C2M.LE.ASCLE) GO TO 100
        IFLAG = IFLAG + 1
        ASCLE = BRY(IFLAG)
        S1 = S1*C1
        S2 = C2
        S1 = S1*CSS(IFLAG)
        S2 = S2*CSS(IFLAG)
        C1 = CSR(IFLAG)
  100 CONTINUE
  110 CONTINUE
      RETURN
  120 CONTINUE
      IF (RS1.GT.0.0E0) GO TO 140
C-----------------------------------------------------------------------
C SET UNDERFLOW AND UPDATE PARAMETERS
C-----------------------------------------------------------------------
      Y(ND) = CZERO
      NZ = NZ + 1
      ND = ND - 1
      IF (ND.EQ.0) GO TO 110
      CALL CUOIK(Z, FNU, KODE, 1, ND, Y, NUF, TOL, ELIM, ALIM)
      IF (NUF.LT.0) GO TO 140
      ND = ND - NUF
      NZ = NZ + NUF
      IF (ND.EQ.0) GO TO 110
      FN = FNU + FLOAT(ND-1)
      IF (FN.LT.FNUL) GO TO 130
      FN = DIMAG(CID)
      J = NUF + 1
      K = MOD(J,4) + 1
      S1 = CIP(K)
      IF (FN.LT.0.0E0) S1 = DCONJG(S1)
      C2 = C2*S1
      GO TO 40
  130 CONTINUE
      NLAST = ND
      RETURN
  140 CONTINUE
      NZ = -1
      RETURN
  150 CONTINUE
      IF (RS1.GT.0.0E0) GO TO 140
      NZ = N
      DO 160 I=1,N
        Y(I) = CZERO
  160 CONTINUE
      RETURN
      END
      SUBROUTINE CUNI1(Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM,
     * ALIM)
C***BEGIN PROLOGUE CUNI1
C***REFER TO CBESI,CBESK
C
C CUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC
C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3.
C
C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
C Y(I)=CZERO FOR I=NLAST+1,N
C
C***ROUTINES CALLED CUCHK,CUNIK,CUOIK,R1MACH
C***END PROLOGUE CUNI1
      DOUBLECOMPLEX
     1 CFN, CONE, CRSC, CSCL, CSR, CSS, CWRK, CZERO, C1, C2,
     * PHI, RZ, SUM, S1, S2, Y, Z, ZETA1, ZETA2, CY
      DOUBLEPRECISION
     1 ALIM, APHI, ASCLE, BRY, C2I, C2M, C2R, ELIM, FN, FNU, FNUL,
     * RS1, TOL, YY, R1MACH
      INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ
      DIMENSION BRY(3), Y(*), CWRK(16), CSS(3), CSR(3), CY(2)
      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
C
      NZ = 0
      ND = N
      NLAST = 0
C-----------------------------------------------------------------------
C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
C EXP(ALIM)=EXP(ELIM)*TOL
C-----------------------------------------------------------------------
C CSCL = DCMPLX(1.0E0/TOL,0.0E0)
C CRSC = DCMPLX(TOL,0.0E0)
      CSCL = 1.0E0/TOL
      CRSC = TOL
      CSS(1) = CSCL
      CSS(2) = CONE
      CSS(3) = CRSC
      CSR(1) = CRSC
      CSR(2) = CONE
      CSR(3) = CSCL
      BRY(1) = 1.0E+3*R1MACH(1)/TOL
C-----------------------------------------------------------------------
C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
C-----------------------------------------------------------------------
      FN = DMAX1(FNU,DBLE(1.0E0))
      INIT = 0
      CALL CUNIK(Z, FN, 1, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK)
      IF (KODE.EQ.1) GO TO 10
C CFN = DCMPLX(FN,0.0E0)
      CFN = FN
      S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2))
      GO TO 20
   10 CONTINUE
      S1 = -ZETA1 + ZETA2
   20 CONTINUE
      RS1 = DBLE(S1)
      IF (ABS(RS1).GT.ELIM) GO TO 130
   30 CONTINUE
      NN = MIN0(2,ND)
      DO 80 I=1,NN
        FN = FNU + FLOAT(ND-I)
        INIT = 0
        CALL CUNIK(Z, FN, 1, 0, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK)
        IF (KODE.EQ.1) GO TO 40
C CFN = DCMPLX(FN,0.0E0)
        CFN = FN
        YY = DIMAG(Z)
C S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + DCMPLX(0.0E0,YY)
        S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + (0.,1.)*YY
        GO TO 50
   40 CONTINUE
        S1 = -ZETA1 + ZETA2
   50 CONTINUE
C-----------------------------------------------------------------------
C TEST FOR UNDERFLOW AND OVERFLOW
C-----------------------------------------------------------------------
        RS1 = DBLE(S1)
        IF (ABS(RS1).GT.ELIM) GO TO 110
        IF (I.EQ.1) IFLAG = 2
        IF (ABS(RS1).LT.ALIM) GO TO 60
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
        APHI = ZABS(PHI)
        RS1 = RS1 + DLOG(APHI)
        IF (ABS(RS1).GT.ELIM) GO TO 110
        IF (I.EQ.1) IFLAG = 1
        IF (RS1.LT.0.0E0) GO TO 60
        IF (I.EQ.1) IFLAG = 3
   60 CONTINUE
C-----------------------------------------------------------------------
C SCALE S1 IF ZABS(S1).LT.ASCLE
C-----------------------------------------------------------------------
        S2 = PHI*SUM
        C2R = DBLE(S1)
        C2I = DIMAG(S1)
        C2M = EXP(C2R)*DBLE(CSS(IFLAG))
C S1 = DCMPLX(C2M,0.0E0)*DCMPLX(COS(C2I),SIN(C2I))
        S1 = C2M*DCMPLX(COS(C2I),SIN(C2I))
        S2 = S2*S1
        IF (IFLAG.NE.1) GO TO 70
        CALL CUCHK(S2, NW, BRY(1), TOL)
        IF (NW.NE.0) GO TO 110
   70 CONTINUE
        M = ND - I + 1
        CY(I) = S2
        Y(M) = S2*CSR(IFLAG)
   80 CONTINUE
      IF (ND.LE.2) GO TO 100
C RZ = DCMPLX(2.0E0,0.0E0)/Z
      RZ = 2./Z
      BRY(2) = 1.0E0/BRY(1)
      BRY(3) = R1MACH(2)
      S1 = CY(1)
      S2 = CY(2)
      C1 = CSR(IFLAG)
      ASCLE = BRY(IFLAG)
      K = ND - 2
      FN = FLOAT(K)
      DO 90 I=3,ND
        C2 = S2
C S2 = S1 + DCMPLX(FNU+FN,0.0E0)*RZ*S2
        S2 = S1 + (FNU+FN)*RZ*S2
        S1 = C2
        C2 = S2*C1
        Y(K) = C2
        K = K - 1
        FN = FN - 1.0E0
        IF (IFLAG.GE.3) GO TO 90
        C2R = DBLE(C2)
        C2I = DIMAG(C2)
        C2R = ABS(C2R)
        C2I = ABS(C2I)
        C2M = DMAX1(C2R,C2I)
        IF (C2M.LE.ASCLE) GO TO 90
        IFLAG = IFLAG + 1
        ASCLE = BRY(IFLAG)
        S1 = S1*C1
        S2 = C2
        S1 = S1*CSS(IFLAG)
        S2 = S2*CSS(IFLAG)
        C1 = CSR(IFLAG)
   90 CONTINUE
  100 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C SET UNDERFLOW AND UPDATE PARAMETERS
C-----------------------------------------------------------------------
  110 CONTINUE
      IF (RS1.GT.0.0E0) GO TO 120
      Y(ND) = CZERO
      NZ = NZ + 1
      ND = ND - 1
      IF (ND.EQ.0) GO TO 100
      CALL CUOIK(Z, FNU, KODE, 1, ND, Y, NUF, TOL, ELIM, ALIM)
      IF (NUF.LT.0) GO TO 120
      ND = ND - NUF
      NZ = NZ + NUF
      IF (ND.EQ.0) GO TO 100
      FN = FNU + FLOAT(ND-1)
      IF (FN.GE.FNUL) GO TO 30
      NLAST = ND
      RETURN
  120 CONTINUE
      NZ = -1
      RETURN
  130 CONTINUE
      IF (RS1.GT.0.0E0) GO TO 120
      NZ = N
      DO 140 I=1,N
        Y(I) = CZERO
  140 CONTINUE
      RETURN
      END
      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
      DOUBLECOMPLEX
     1 CZERO, C1, S1, S1D, S2, ZR
      DOUBLEPRECISION
     1 AA, ALIM, ALN, ASCLE, AS1, AS2, XX
      INTEGER IUF, NZ
      DATA CZERO / (0.0E0,0.0E0) /
      NZ = 0
      AS1 = ZABS(S1)
      AS2 = ZABS(S2)
      AA = DBLE(S1)
      ALN = DIMAG(S1)
      IF (AA.EQ.0.0E0 .AND. ALN.EQ.0.0E0) GO TO 10
      IF (AS1.EQ.0.0E0) GO TO 10
      XX = DBLE(ZR)
      ALN = -XX - XX + DLOG(AS1)
      S1D = S1
      S1 = CZERO
      AS1 = 0.0E0
      IF (ALN.LT.(-ALIM)) GO TO 10
      C1 = ZLOG(S1D) - ZR - ZR
      S1 = ZEXP(C1)
      AS1 = ZABS(S1)
      IUF = IUF + 1
   10 CONTINUE
      AA = DMAX1(AS1,AS2)
      IF (AA.GT.ASCLE) RETURN
      S1 = CZERO
      S2 = CZERO
      NZ = 1
      IUF = 0
      RETURN
      END
      SUBROUTINE CSHCH(Z, CSH, CCH)
C***BEGIN PROLOGUE CSHCH
C***REFER TO CBESK,CBESH
C
C CSHCH COMPUTES THE DOUBLECOMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
C AND CCH=COSH(X+I*Y), WHERE I**2=-1.
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE CSHCH
      DOUBLECOMPLEX
     1 CCH, CSH, Z
      DOUBLEPRECISION
     1 CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y, COSH, SINH
      X = DBLE(Z)
      Y = DIMAG(Z)
      SH = SINH(X)
      CH = COSH(X)
      SN = SIN(Y)
      CN = COS(Y)
      CSHR = SH*CN
      CSHI = CH*SN
      CSH = DCMPLX(CSHR,CSHI)
      CCHR = CH*CN
      CCHI = SH*SN
      CCH = DCMPLX(CCHR,CCHI)
      RETURN
      END
      SUBROUTINE CRATI(Z, FNU, N, CY, TOL)
C***BEGIN PROLOGUE CRATI
C***REFER TO CBESI,CBESK,CBESH
C
C CRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD
C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD
C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B,
C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973,
C BESSEL FUNCTIONS I AND J OF DOUBLECOMPLEX ARGUMENT AND INTEGER ORDER,
C BY D. J. SOOKNE.
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE CRATI
      DOUBLECOMPLEX
     1 CDFNU, CONE, CY, CZERO, PT, P1, P2, RZ, T1, Z
      DOUBLEPRECISION
     1 AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, FNU, FNUP,
     * RAP1, RHO, TEST, TEST1, TOL
      INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N
      DIMENSION CY(1)
      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
      AZ = ZABS(Z)
      INU = INT(FNU)
      IDNU = INU + N - 1
      FDNU = FLOAT(IDNU)
      MAGZ = INT(AZ)
      AMAGZ = FLOAT(MAGZ+1)
      FNUP = DMAX1(AMAGZ,FDNU)
      ID = IDNU - MAGZ - 1
      ITIME = 1
      K = 1
      RZ = (CONE+CONE)/Z
C T1 = DCMPLX(FNUP,0.0E0)*RZ
      T1 = FNUP*RZ
      P2 = -T1
      P1 = CONE
      T1 = T1 + RZ
      IF (ID.GT.0) ID = 0
      AP2 = ZABS(P2)
      AP1 = ZABS(P1)
C-----------------------------------------------------------------------
C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX
C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT
C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR
C PREMATURELY.
C-----------------------------------------------------------------------
      ARG = (AP2+AP2)/(AP1*TOL)
      TEST1 = SQRT(ARG)
      TEST = TEST1
      RAP1 = 1.0E0/AP1
C P1 = P1*DCMPLX(RAP1,0.0E0)
C P2 = P2*DCMPLX(RAP1,0.0E0)
      P1 = P1*RAP1
      P2 = P2*RAP1
      AP2 = AP2*RAP1
   10 CONTINUE
      K = K + 1
      AP1 = AP2
      PT = P2
      P2 = P1 - T1*P2
      P1 = PT
      T1 = T1 + RZ
      AP2 = ZABS(P2)
      IF (AP1.LE.TEST) GO TO 10
      IF (ITIME.EQ.2) GO TO 20
      AK = ZABS(T1)*0.5E0
      FLAM = AK + SQRT(AK*AK-1.0E0)
      RHO = DMIN1(AP2/AP1,FLAM)
      TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0))
      ITIME = 2
      GO TO 10
   20 CONTINUE
      KK = K + 1 - ID
      AK = FLOAT(KK)
      DFNU = FNU + FLOAT(N-1)
C CDFNU = DCMPLX(DFNU,0.0E0)
C T1 = DCMPLX(AK,0.0E0)
C P1 = DCMPLX(1.0E0/AP2,0.0E0)
      CDFNU = DFNU
      T1 = AK
      P1 = 1./AP2
      P2 = CZERO
      DO 30 I=1,KK
        PT = P1
        P1 = RZ*(CDFNU+T1)*P1 + P2
        P2 = PT
        T1 = T1 - CONE
   30 CONTINUE
      IF (DBLE(P1).NE.0.0E0 .OR. DIMAG(P1).NE.0.0E0) GO TO 40
      P1 = DCMPLX(TOL,TOL)
   40 CONTINUE
      CY(N) = P2/P1
      IF (N.EQ.1) RETURN
      K = N - 1
      AK = FLOAT(K)
C T1 = DCMPLX(AK,0.0E0)
C CDFNU = DCMPLX(FNU,0.0E0)*RZ
      T1 = AK
      CDFNU = FNU*RZ
      DO 60 I=2,N
        PT = CDFNU + T1*RZ + CY(K+1)
        IF (DBLE(PT).NE.0.0E0 .OR. DIMAG(PT).NE.0.0E0) GO TO 50
        PT = DCMPLX(TOL,TOL)
   50 CONTINUE
        CY(K) = CONE/PT
        T1 = T1 - CONE
        K = K - 1
   60 CONTINUE
      RETURN
      END
      SUBROUTINE CBKNU(Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CBKNU
C***REFER TO CBESI,CBESK,CAIRY,CBESH
C
C CBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE
C
C***ROUTINES CALLED CKSCL,CSHCH,GAMLN,I1MACH,R1MACH,CUCHK
C***END PROLOGUE CBKNU
C
      DOUBLECOMPLEX
     1 CCH, CK, COEF, CONE, CRSC, CS, CSCL, CSH, CSR, CSS, CTWO,
     * CZ, CZERO, F, FMU, P, PT, P1, P2, Q, RZ, SMU, ST, S1, S2, Y, Z,
     * ZD, CELM, CY
      DOUBLEPRECISION
     1 AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, CC, DNU,
     * DNU2, ELIM, ETEST, FC, FHS, FK, FKS, FNU, FPI, G1, G2, HPI, PI,
     * P2I, P2M, P2R, RK, RTHPI, R1, S, SPI, TM, TOL, TTH, T1, T2, XX,
     * YY, GAMLN, R1MACH, HELIM, ELM, XD, YD, ALAS, AS
      INTEGER I, IDUM, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N,
     * NZ, I1MACH, NW, J, IC, INUB
      DIMENSION BRY(3), CC(8), CSS(3), CSR(3), Y(*), CY(2)
C
      DATA KMAX / 30 /
      DATA R1 / 2.0E0 /
      DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/
C
      DATA PI, RTHPI, SPI ,HPI, FPI, TTH /
     1 3.14159265358979324E0, 1.25331413731550025E0,
     2 1.90985931710274403E0, 1.57079632679489662E0,
     3 1.89769999331517738E0, 6.66666666666666666E-01/
C
      DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/
     1 5.77215664901532861E-01, -4.20026350340952355E-02,
     2 -4.21977345555443367E-02, 7.21894324666309954E-03,
     3 -2.15241674114950973E-04, -2.01348547807882387E-05,
     4 1.13302723198169588E-06, 6.11609510448141582E-09/
C
      XX = DBLE(Z)
      YY = DIMAG(Z)
      CAZ = ZABS(Z)
C CSCL = DCMPLX(1.0E0/TOL,0.0E0)
C CRSC = DCMPLX(TOL,0.0E0)
      CSCL = 1./TOL
      CRSC = TOL
      CSS(1) = CSCL
      CSS(2) = CONE
      CSS(3) = CRSC
      CSR(1) = CRSC
      CSR(2) = CONE
      CSR(3) = CSCL
      BRY(1) = 1.0E+3*R1MACH(1)/TOL
      BRY(2) = 1.0E0/BRY(1)
      BRY(3) = R1MACH(2)
      NZ = 0
      IFLAG = 0
      KODED = KODE
      RZ = CTWO/Z
      INU = INT(FNU+0.5E0)
      DNU = FNU - FLOAT(INU)
      IF (ABS(DNU).EQ.0.5E0) GO TO 110
      DNU2 = 0.0E0
      IF (ABS(DNU).GT.TOL) DNU2 = DNU*DNU
      IF (CAZ.GT.R1) GO TO 110
C-----------------------------------------------------------------------
C SERIES FOR ZABS(Z).LE.R1
C-----------------------------------------------------------------------
      FC = 1.0E0
      SMU = ZLOG(RZ)
C FMU = SMU*DCMPLX(DNU,0.0E0)
      FMU = SMU*DNU
      CALL CSHCH(FMU, CSH, CCH)
      IF (DNU.EQ.0.0E0) GO TO 10
      FC = DNU*PI
      FC = FC/SIN(FC)
C SMU = CSH*DCMPLX(1.0E0/DNU,0.0E0)
      SMU = CSH*1./DNU
   10 CONTINUE
      A2 = 1.0E0 + DNU
C-----------------------------------------------------------------------
C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU)
C-----------------------------------------------------------------------
      T2 = EXP(-GAMLN(A2,IDUM))
      T1 = 1.0E0/(T2*FC)
      IF (ABS(DNU).GT.0.1E0) GO TO 40
C-----------------------------------------------------------------------
C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
C-----------------------------------------------------------------------
      AK = 1.0E0
      S = CC(1)
      DO 20 K=2,8
        AK = AK*DNU2
        TM = CC(K)*AK
        S = S + TM
        IF (ABS(TM).LT.TOL) GO TO 30
   20 CONTINUE
   30 G1 = -S
      GO TO 50
   40 CONTINUE
      G1 = (T1-T2)/(DNU+DNU)
   50 CONTINUE
      G2 = 0.5E0*(T1+T2)*FC
      G1 = G1*FC
C F = DCMPLX(G1,0.0E0)*CCH + SMU*DCMPLX(G2,0.0E0)
      F = G1*CCH + SMU*G2
      PT = ZEXP(FMU)
C P = DCMPLX(0.5E0/T2,0.0E0)*PT
C Q = DCMPLX(0.5E0/T1,0.0E0)/PT
      P = .5/T2*PT
      Q = .5/T1/PT
      S1 = F
      S2 = P
      AK = 1.0E0
      A1 = 1.0E0
      CK = CONE
      BK = 1.0E0 - DNU2
      IF (INU.GT.0 .OR. N.GT.1) GO TO 80
C-----------------------------------------------------------------------
C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1
C-----------------------------------------------------------------------
      IF (CAZ.LT.TOL) GO TO 70
C CZ = Z*Z*DCMPLX(0.25E0,0.0E0)
C T1 = 0.25E0*CAZ*CAZ
      CZ = Z**2 / 4
      T1 = CAZ**2 / 4
   60 CONTINUE
C F = (F*DCMPLX(AK,0.0E0)+P+Q)*DCMPLX(1.0E0/BK,0.0E0)
C P = P*DCMPLX(1.0E0/(AK-DNU),0.0E0)
C Q = Q*DCMPLX(1.0E0/(AK+DNU),0.0E0)
C RK = 1.0E0/AK
C CK = CK*CZ*DCMPLX(RK,0.0)
      F = (F*AK+P+Q)/BK
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      RK = 1./AK
      CK = CK*CZ*RK
      S1 = S1 + CK*F
      A1 = A1*T1*RK
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      IF (A1.GT.TOL) GO TO 60
   70 CONTINUE
      Y(1) = S1
      IF (KODED.EQ.1) RETURN
      Y(1) = S1*ZEXP(Z)
      RETURN
C-----------------------------------------------------------------------
C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE
C-----------------------------------------------------------------------
   80 CONTINUE
      IF (CAZ.LT.TOL) GO TO 100
C CZ = Z*Z*DCMPLX(0.25E0,0.0E0)
C T1 = 0.25E0*CAZ*CAZ
      CZ = Z**2 / 4
      T1 = CAZ**2 / 4
   90 CONTINUE
C F = (F*DCMPLX(AK,0.0E0)+P+Q)*DCMPLX(1.0E0/BK,0.0E0)
C P = P*DCMPLX(1.0E0/(AK-DNU),0.0E0)
C Q = Q*DCMPLX(1.0E0/(AK+DNU),0.0E0)
C RK = 1.0E0/AK
C CK = CK*CZ*DCMPLX(RK,0.0E0)
C S1 = S1 + CK*F
C S2 = S2 + CK*(P-F*DCMPLX(AK,0.0E0))
      F = (F*AK+P+Q)/BK
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      RK = 1./AK
      CK = CK*CZ*RK
      S1 = S1 + CK*F
      S2 = S2 + CK*(P-F*AK)
      A1 = A1*T1*RK
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      IF (A1.GT.TOL) GO TO 90
  100 CONTINUE
      KFLAG = 2
      BK = DBLE(SMU)
      A1 = FNU + 1.0E0
      AK = A1*ABS(BK)
      IF (AK.GT.ALIM) KFLAG = 3
      P2 = S2*CSS(KFLAG)
      S2 = P2*RZ
      S1 = S1*CSS(KFLAG)
      IF (KODED.EQ.1) GO TO 210
      F = ZEXP(Z)
      S1 = S1*F
      S2 = S2*F
      GO TO 210
C-----------------------------------------------------------------------
C IFLAG=0 MEANS NO UNDERFLOW OCCURRED
C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
C RECURSION
C-----------------------------------------------------------------------
  110 CONTINUE
C COEF = DCMPLX(RTHPI,0.0E0)/ZSQRT(Z)
      COEF = RTHPI/ZSQRT(Z)
      KFLAG = 2
      IF (KODED.EQ.2) GO TO 120
      IF (XX.GT.ALIM) GO TO 290
C BLANK LINE
      A1 = EXP(-XX)*DBLE(CSS(KFLAG))
C PT = DCMPLX(A1,0.0E0)*DCMPLX(COS(YY),-SIN(YY))
      PT = A1*DCMPLX(COS(YY),-SIN(YY))
      COEF = COEF*PT
  120 CONTINUE
      IF (ABS(DNU).EQ.0.5E0) GO TO 300
C-----------------------------------------------------------------------
C MILLER ALGORITHM FOR ZABS(Z).GT.R1
C-----------------------------------------------------------------------
      AK = COS(PI*DNU)
      AK = ABS(AK)
      IF (AK.EQ.0.0E0) GO TO 300
      FHS = ABS(0.25E0-DNU2)
      IF (FHS.EQ.0.0E0) GO TO 300
C-----------------------------------------------------------------------
C COMPUTE R2=F(E). IF ZABS(Z).GE.R2, USE FORWARD RECURRENCE TO
C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON
C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(11))=
C TOL WHERE B IS THE BASE OF THE ARITHMETIC.
C-----------------------------------------------------------------------
      T1 = FLOAT(I1MACH(11)-1)*R1MACH(5)*3.321928094E0
      T1 = DMAX1(T1,DBLE(12.0E0))
      T1 = DMIN1(T1,DBLE(60.0E0))
      T2 = TTH*T1 - 6.0E0
      IF (XX.NE.0.0E0) GO TO 130
      T1 = HPI
      GO TO 140
  130 CONTINUE
      T1 = ATAN(YY/XX)
      T1 = ABS(T1)
  140 CONTINUE
      IF (T2.GT.CAZ) GO TO 170
C-----------------------------------------------------------------------
C FORWARD RECURRENCE LOOP WHEN ZABS(Z).GE.R2
C-----------------------------------------------------------------------
      ETEST = AK/(PI*CAZ*TOL)
      FK = 1.0E0
      IF (ETEST.LT.1.0E0) GO TO 180
      FKS = 2.0E0
      RK = CAZ + CAZ + 2.0E0
      A1 = 0.0E0
      A2 = 1.0E0
      DO 150 I=1,KMAX
        AK = FHS/FKS
        BK = RK/(FK+1.0E0)
        TM = A2
        A2 = BK*A2 - AK*A1
        A1 = TM
        RK = RK + 2.0E0
        FKS = FKS + FK + FK + 2.0E0
        FHS = FHS + FK + FK
        FK = FK + 1.0E0
        TM = ABS(A2)*FK
        IF (ETEST.LT.TM) GO TO 160
  150 CONTINUE
      GO TO 310
  160 CONTINUE
      FK = FK + SPI*T1*SQRT(T2/CAZ)
      FHS = ABS(0.25E0-DNU2)
      GO TO 180
  170 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE BACKWARD INDEX K FOR ZABS(Z).LT.R2
C-----------------------------------------------------------------------
      A2 = SQRT(CAZ)
      AK = FPI*AK/(TOL*SQRT(A2))
      AA = 3.0E0*T1/(1.0E0+CAZ)
      BB = 14.7E0*T1/(28.0E0+CAZ)
      AK = (DLOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB)
      FK = 0.12125E0*AK*AK/CAZ + 1.5E0
  180 CONTINUE
      K = INT(FK)
C-----------------------------------------------------------------------
C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM
C-----------------------------------------------------------------------
      FK = FLOAT(K)
      FKS = FK*FK
      P1 = CZERO
C P2 = DCMPLX(TOL,0.0E0)
      P2 = TOL
      CS = P2
      DO 190 I=1,K
        A1 = FKS - FK
        A2 = (FKS+FK)/(A1+FHS)
        RK = 2.0E0/(FK+1.0E0)
        T1 = (FK+XX)*RK
        T2 = YY*RK
        PT = P2
C P2 = (P2*DCMPLX(T1,T2)-P1)*DCMPLX(A2,0.0E0)
        P2 = (P2*DCMPLX(T1,T2)-P1)*A2
        P1 = PT
        CS = CS + P2
        FKS = A1 - FK + 1.0E0
        FK = FK - 1.0E0
  190 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE (P2/CS)=(P2/ZABS(CS))*(DCONJG(CS)/ZABS(CS)) FOR BETTER
C SCALING
C-----------------------------------------------------------------------
      TM = ZABS(CS)
C PT = DCMPLX(1.0E0/TM,0.0E0)
      PT = 1./TM
      S1 = PT*P2
      CS = DCONJG(CS)*PT
      S1 = COEF*S1*CS
      IF (INU.GT.0 .OR. N.GT.1) GO TO 200
      ZD = Z
      IF(IFLAG.EQ.1) GO TO 270
      GO TO 240
  200 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE P1/P2=(P1/ZABS(P2)*DCONJG(P2)/ZABS(P2) FOR SCALING
C-----------------------------------------------------------------------
      TM = ZABS(P2)
C PT = DCMPLX(1.0E0/TM,0.0E0)
      PT = 1./TM
      P1 = PT*P1
      P2 = DCONJG(P2)*PT
      PT = P1*P2
C S2 = S1*(CONE+(DCMPLX(DNU+0.5E0,0.0E0)-PT)/Z)
      S2 = S1*(CONE+((DNU+.5)-PT)/Z)
C-----------------------------------------------------------------------
C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH
C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3
C-----------------------------------------------------------------------
  210 CONTINUE
C CK = DCMPLX(DNU+1.0E0,0.0E0)*RZ
      CK = (DNU+1.)*RZ
      IF (N.EQ.1) INU = INU - 1
      IF (INU.GT.0) GO TO 220
      IF (N.EQ.1) S1=S2
      ZD = Z
      IF(IFLAG.EQ.1) GO TO 270
      GO TO 240
  220 CONTINUE
      INUB = 1
      IF (IFLAG.EQ.1) GO TO 261
  225 CONTINUE
      P1 = CSR(KFLAG)
      ASCLE = BRY(KFLAG)
      DO 230 I=INUB,INU
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        CK = CK + RZ
        IF (KFLAG.GE.3) GO TO 230
        P2 = S2*P1
        P2R = DBLE(P2)
        P2I = DIMAG(P2)
        P2R = ABS(P2R)
        P2I = ABS(P2I)
        P2M = DMAX1(P2R,P2I)
        IF (P2M.LE.ASCLE) GO TO 230
        KFLAG = KFLAG + 1
        ASCLE = BRY(KFLAG)
        S1 = S1*P1
        S2 = P2
        S1 = S1*CSS(KFLAG)
        S2 = S2*CSS(KFLAG)
        P1 = CSR(KFLAG)
  230 CONTINUE
      IF (N.EQ.1) S1 = S2
  240 CONTINUE
      Y(1) = S1*CSR(KFLAG)
      IF (N.EQ.1) RETURN
      Y(2) = S2*CSR(KFLAG)
      IF (N.EQ.2) RETURN
      KK = 2
  250 CONTINUE
      KK = KK + 1
      IF (KK.GT.N) RETURN
      P1 = CSR(KFLAG)
      ASCLE = BRY(KFLAG)
      DO 260 I=KK,N
        P2 = S2
        S2 = CK*S2 + S1
        S1 = P2
        CK = CK + RZ
        P2 = S2*P1
        Y(I) = P2
        IF (KFLAG.GE.3) GO TO 260
        P2R = DBLE(P2)
        P2I = DIMAG(P2)
        P2R = ABS(P2R)
        P2I = ABS(P2I)
        P2M = DMAX1(P2R,P2I)
        IF (P2M.LE.ASCLE) GO TO 260
        KFLAG = KFLAG + 1
        ASCLE = BRY(KFLAG)
        S1 = S1*P1
        S2 = P2
        S1 = S1*CSS(KFLAG)
        S2 = S2*CSS(KFLAG)
        P1 = CSR(KFLAG)
  260 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW
C-----------------------------------------------------------------------
  261 CONTINUE
      HELIM = 0.5E0*ELIM
      ELM = EXP(-ELIM)
C CELM = DCMPLX(ELM,0.0)
      CELM = ELM
      ASCLE = BRY(1)
      ZD = Z
      XD = XX
      YD = YY
      IC = -1
      J = 2
      DO 262 I=1,INU
        ST = S2
        S2 = CK*S2+S1
        S1 = ST
        CK = CK+RZ
        AS = ZABS(S2)
        ALAS = DLOG(AS)
        P2R = -XD+ALAS
        IF(P2R.LT.(-ELIM)) GO TO 263
        P2 = -ZD+ZLOG(S2)
        P2R = DBLE(P2)
        P2I = DIMAG(P2)
        P2M = EXP(P2R)/TOL
C P1 = DCMPLX(P2M,0.0E0)*DCMPLX(COS(P2I),SIN(P2I))
        P1 = P2M*DCMPLX(COS(P2I),SIN(P2I))
        CALL CUCHK(P1,NW,ASCLE,TOL)
        IF(NW.NE.0) GO TO 263
        J=3-J
        CY(J) = P1
        IF(IC.EQ.(I-1)) GO TO 264
        IC = I
        GO TO 262
  263 CONTINUE
        IF(ALAS.LT.HELIM) GO TO 262
        XD = XD-ELIM
        S1 = S1*CELM
        S2 = S2*CELM
        ZD = DCMPLX(XD,YD)
  262 CONTINUE
      IF(N.EQ.1) S1 = S2
      GO TO 270
  264 CONTINUE
      KFLAG = 1
      INUB = I+1
      S2 = CY(J)
      J = 3 - J
      S1 = CY(J)
      IF(INUB.LE.INU) GO TO 225
      IF(N.EQ.1) S1 = S2
      GO TO 240
  270 CONTINUE
      Y(1) = S1
      IF (N.EQ.1) GO TO 280
      Y(2) = S2
  280 CONTINUE
      ASCLE = BRY(1)
      CALL CKSCL(ZD, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM)
      INU = N - NZ
      IF (INU.LE.0) RETURN
      KK = NZ + 1
      S1 = Y(KK)
      Y(KK) = S1*CSR(1)
      IF (INU.EQ.1) RETURN
      KK = NZ + 2
      S2 = Y(KK)
      Y(KK) = S2*CSR(1)
      IF (INU.EQ.2) RETURN
      T2 = FNU + FLOAT(KK-1)
C CK = DCMPLX(T2,0.0E0)*RZ
      CK = T2*RZ
      KFLAG = 1
      GO TO 250
  290 CONTINUE
C-----------------------------------------------------------------------
C SCALE BY EXP(Z), IFLAG = 1 CASES
C-----------------------------------------------------------------------
      KODED = 2
      IFLAG = 1
      KFLAG = 2
      GO TO 120
C-----------------------------------------------------------------------
C FNU=HALF ODD INTEGER CASE, DNU=-0.5
C-----------------------------------------------------------------------
  300 CONTINUE
      S1 = COEF
      S2 = COEF
      GO TO 210
  310 CONTINUE
      NZ=-2
      RETURN
      END
      SUBROUTINE CKSCL(ZR, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM)
C***BEGIN PROLOGUE CKSCL
C***REFER TO CBKNU,CUNK1,CUNK2
C
C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE
C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN
C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.
C
C***ROUTINES CALLED CUCHK
C***END PROLOGUE CKSCL
      DOUBLECOMPLEX
     1 CK, CS, CY, CZERO, RZ, S1, S2, Y, ZR, ZD, CELM
      DOUBLEPRECISION
     1 AA, ASCLE, ACS, AS, CSI, CSR, ELIM, FN, FNU, TOL, XX, ZRI,
     * ELM, ALAS, HELIM
      INTEGER I, IC, K, KK, N, NN, NW, NZ
      DIMENSION Y(*), CY(2)
      DATA CZERO / (0.0E0,0.0E0) /
C
      NZ = 0
      IC = 0
      XX = DBLE(ZR)
      NN = MIN0(2,N)
      DO 10 I=1,NN
        S1 = Y(I)
        CY(I) = S1
        AS = ZABS(S1)
        ACS = -XX + DLOG(AS)
        NZ = NZ + 1
        Y(I) = CZERO
        IF (ACS.LT.(-ELIM)) GO TO 10
        CS = -ZR + ZLOG(S1)
        CSR = DBLE(CS)
        CSI = DIMAG(CS)
        AA = EXP(CSR)/TOL
C CS = DCMPLX(AA,0.0E0)*DCMPLX(COS(CSI),SIN(CSI))
        CS = AA*DCMPLX(COS(CSI),SIN(CSI))
        CALL CUCHK(CS, NW, ASCLE, TOL)
        IF (NW.NE.0) GO TO 10
        Y(I) = CS
        NZ = NZ - 1
        IC = I
   10 CONTINUE
      IF (N.EQ.1) RETURN
      IF (IC.GT.1) GO TO 20
      Y(1) = CZERO
      NZ = 2
   20 CONTINUE
      IF (N.EQ.2) RETURN
      IF (NZ.EQ.0) RETURN
      FN = FNU + 1.0E0
C CK = DCMPLX(FN,0.0E0)*RZ
      CK = FN*RZ
      S1 = CY(1)
      S2 = CY(2)
      HELIM = 0.5E0*ELIM
      ELM = EXP(-ELIM)
C CELM = DCMPLX(ELM,0.0E0)
      CELM = ELM
      ZRI =DIMAG(ZR)
      ZD = ZR
C
C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF
C S2 GETS LARGER THAN EXP(ELIM/2)
C
      DO 30 I=3,N
        KK = I
        CS = S2
        S2 = CK*S2 + S1
        S1 = CS
        CK = CK + RZ
        AS = ZABS(S2)
        ALAS = DLOG(AS)
        ACS = -XX + ALAS
        NZ = NZ + 1
        Y(I) = CZERO
        IF (ACS.LT.(-ELIM)) GO TO 25
        CS = -ZD + ZLOG(S2)
        CSR = DBLE(CS)
        CSI = DIMAG(CS)
        AA = EXP(CSR)/TOL
C CS = DCMPLX(AA,0.0E0)*DCMPLX(COS(CSI),SIN(CSI))
        CS = AA*DCMPLX(COS(CSI),SIN(CSI))
        CALL CUCHK(CS, NW, ASCLE, TOL)
        IF (NW.NE.0) GO TO 25
        Y(I) = CS
        NZ = NZ - 1
        IF (IC.EQ.(KK-1)) GO TO 40
        IC = KK
        GO TO 30
   25 CONTINUE
        IF(ALAS.LT.HELIM) GO TO 30
        XX = XX-ELIM
        S1 = S1*CELM
        S2 = S2*CELM
        ZD = DCMPLX(XX,ZRI)
   30 CONTINUE
      NZ = N
      IF(IC.EQ.N) NZ=N-1
      GO TO 45
   40 CONTINUE
      NZ = KK - 2
   45 CONTINUE
      DO 50 K=1,NZ
        Y(K) = CZERO
   50 CONTINUE
      RETURN
      END
      SUBROUTINE CACON(Z, FNU, KODE, MR, N, Y, NZ, RL, FNUL, TOL, ELIM,
     * ALIM)
C***BEGIN PROLOGUE CACON
C***REFER TO CBESK,CBESH
C
C CACON APPLIES THE ANALYTIC CONTINUATION FORMULA
C
C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
C MP=PI*MR*DCMPLX(0.0,1.0)
C
C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
C HALF Z PLANE
C
C***ROUTINES CALLED CBINU,CBKNU,CS1S2,R1MACH
C***END PROLOGUE CACON
      DOUBLECOMPLEX
     1 CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, CSS, CSR, C1, C2,
     * RZ, SC1, SC2, ST, S1, S2, Y, Z, ZN, CY
      DOUBLEPRECISION
     1 ALIM, ARG, ASCLE, AS2, BSCLE, BRY, CPN, C1I, C1M, C1R, ELIM,
     * FMR, FNU, FNUL, PI, RL, SGN, SPN, TOL, YY, R1MACH
      INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ
      DIMENSION Y(*), CY(2), CSS(3), CSR(3), BRY(3)
      DATA PI / 3.14159265358979324E0 /
      DATA CONE / (1.0E0,0.0E0) /
      NZ = 0
      ZN = -Z
      NN = N
      CALL CBINU(ZN, FNU, KODE, NN, Y, NW, RL, FNUL, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 80
C-----------------------------------------------------------------------
C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
C-----------------------------------------------------------------------
      NN = MIN0(2,N)
      CALL CBKNU(ZN, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM)
      IF (NW.NE.0) GO TO 80
      S1 = CY(1)
      FMR = FLOAT(MR)
      SGN = -SIGN(PI,FMR)
C CSGN = DCMPLX(0.0E0,SGN)
      CSGN = (0.,1.)*SGN
      IF (KODE.EQ.1) GO TO 10
      YY = -DIMAG(ZN)
      CPN = COS(YY)
      SPN = SIN(YY)
      CSGN = CSGN*DCMPLX(CPN,SPN)
   10 CONTINUE
C-----------------------------------------------------------------------
C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
C WHEN FNU IS LARGE
C-----------------------------------------------------------------------
      INU = INT(FNU)
      ARG = (FNU-FLOAT(INU))*SGN
      CPN = COS(ARG)
      SPN = SIN(ARG)
      CSPN = DCMPLX(CPN,SPN)
      IF (MOD(INU,2).EQ.1) CSPN = -CSPN
      IUF = 0
      C1 = S1
      C2 = Y(1)
      ASCLE = 1.0E+3*R1MACH(1)/TOL
      IF (KODE.EQ.1) GO TO 20
      CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
      NZ = NZ + NW
      SC1 = C1
   20 CONTINUE
      Y(1) = CSPN*C1 + CSGN*C2
      IF (N.EQ.1) RETURN
      CSPN = -CSPN
      S2 = CY(2)
      C1 = S2
      C2 = Y(2)
      IF (KODE.EQ.1) GO TO 30
      CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
      NZ = NZ + NW
      SC2 = C1
   30 CONTINUE
      Y(2) = CSPN*C1 + CSGN*C2
      IF (N.EQ.2) RETURN
      CSPN = -CSPN
C RZ = DCMPLX(2.0E0,0.0E0)/ZN
C CK = DCMPLX(FNU+1.0E0,0.0E0)*RZ
      RZ = 2./ZN
      CK = (FNU+1.)*RZ
C-----------------------------------------------------------------------
C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS
C-----------------------------------------------------------------------
C CSCL = DCMPLX(1.0E0/TOL,0.0E0)
C CSCR = DCMPLX(TOL,0.0E0)
      CSCL = 1./TOL
      CSCR = TOL
      CSS(1) = CSCL
      CSS(2) = CONE
      CSS(3) = CSCR
      CSR(1) = CSCR
      CSR(2) = CONE
      CSR(3) = CSCL
      BRY(1) = ASCLE
      BRY(2) = 1.0E0/ASCLE
      BRY(3) = R1MACH(2)
      AS2 = ZABS(S2)
      KFLAG = 2
      IF (AS2.GT.BRY(1)) GO TO 40
      KFLAG = 1
      GO TO 50
   40 CONTINUE
      IF (AS2.LT.BRY(2)) GO TO 50
      KFLAG = 3
   50 CONTINUE
      BSCLE = BRY(KFLAG)
      S1 = S1*CSS(KFLAG)
      S2 = S2*CSS(KFLAG)
      CS = CSR(KFLAG)
      DO 70 I=3,N
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        C1 = S2*CS
        ST = C1
        C2 = Y(I)
        IF (KODE.EQ.1) GO TO 60
        IF (IUF.LT.0) GO TO 60
        CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
        NZ = NZ + NW
        SC1 = SC2
        SC2 = C1
        IF (IUF.NE.3) GO TO 60
        IUF = -4
        S1 = SC1*CSS(KFLAG)
        S2 = SC2*CSS(KFLAG)
        ST = SC2
   60 CONTINUE
        Y(I) = CSPN*C1 + CSGN*C2
        CK = CK + RZ
        CSPN = -CSPN
        IF (KFLAG.GE.3) GO TO 70
        C1R = DBLE(C1)
        C1I = DIMAG(C1)
        C1R = ABS(C1R)
        C1I = ABS(C1I)
        C1M = DMAX1(C1R,C1I)
        IF (C1M.LE.BSCLE) GO TO 70
        KFLAG = KFLAG + 1
        BSCLE = BRY(KFLAG)
        S1 = S1*CS
        S2 = ST
        S1 = S1*CSS(KFLAG)
        S2 = S2*CSS(KFLAG)
        CS = CSR(KFLAG)
   70 CONTINUE
      RETURN
   80 CONTINUE
      NZ = -1
      IF(NW.EQ.(-2)) NZ=-2
      RETURN
      END
C ***************************************
      SUBROUTINE CBINU(Z, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM,
     * ALIM)
C***BEGIN PROLOGUE CBINU
C***REFER TO CBESH,CBESI,CBESJ,CBESK,CAIRY,CBIRY
C
C CBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE
C
C***ROUTINES CALLED CASYI,CBUNI,CMLRI,CSERI,CUOIK,CWRSK
C***END PROLOGUE CBINU
      DOUBLECOMPLEX
     1 CW, CY, CZERO, Z
      DOUBLEPRECISION
     1 ALIM, AZ, DFNU, ELIM, FNU, FNUL, RL, TOL
      INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ
      DIMENSION CY(1), CW(2)
      DATA CZERO / (0.0E0,0.0E0) /
C
      NZ = 0
      AZ = ZABS(Z)
      NN = N
      DFNU = FNU + FLOAT(N-1)
      IF (AZ.LE.2.0E0) GO TO 10
      IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20
   10 CONTINUE
C-----------------------------------------------------------------------
C POWER SERIES
C-----------------------------------------------------------------------
C write (*,*) ' CBINU: call CSERI..'
      CALL CSERI(Z, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM)
      INW = IABS(NW)
      NZ = NZ + INW
      NN = NN - INW
      IF (NN.EQ.0) RETURN
      IF (NW.GE.0) GO TO 120
      DFNU = FNU + FLOAT(NN-1)
   20 CONTINUE
      IF (AZ.LT.RL) GO TO 40
      IF (DFNU.LE.1.0E0) GO TO 30
      IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR LARGE Z
C-----------------------------------------------------------------------
   30 CONTINUE
C write (*,*) ' CBINU: call CASYI..'
      CALL CASYI(Z, FNU, KODE, NN, CY, NW, RL, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 130
      GO TO 120
   40 CONTINUE
      IF (DFNU.LE.1.0E0) GO TO 70
   50 CONTINUE
C-----------------------------------------------------------------------
C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM
C-----------------------------------------------------------------------
C write (*,*) ' CBINU: call CUOIK..'
      CALL CUOIK(Z, FNU, KODE, 1, NN, CY, NW, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 130
      NZ = NZ + NW
      NN = NN - NW
      IF (NN.EQ.0) RETURN
      DFNU = FNU+FLOAT(NN-1)
      IF (DFNU.GT.FNUL) GO TO 110
      IF (AZ.GT.FNUL) GO TO 110
   60 CONTINUE
      IF (AZ.GT.RL) GO TO 80
   70 CONTINUE
C-----------------------------------------------------------------------
C MILLER ALGORITHM NORMALIZED BY THE SERIES
C-----------------------------------------------------------------------
C write (*,*) ' CBINU: call CMLRI..'
      CALL CMLRI(Z, FNU, KODE, NN, CY, NW, TOL)
      IF(NW.LT.0) GO TO 130
      GO TO 120
   80 CONTINUE
C-----------------------------------------------------------------------
C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN
C-----------------------------------------------------------------------
C write (*,*) ' CBINU: call CUOIK..'
      CALL CUOIK(Z, FNU, KODE, 2, 2, CW, NW, TOL, ELIM, ALIM)
      IF (NW.GE.0) GO TO 100
      NZ = NN
      DO 90 I=1,NN
        CY(I) = CZERO
   90 CONTINUE
      RETURN
  100 CONTINUE
      IF (NW.GT.0) GO TO 130
C write (*,*) ' CBINU: call CWRSK..'
      CALL CWRSK(Z, FNU, KODE, NN, CY, NW, CW, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 130
      GO TO 120
  110 CONTINUE
C-----------------------------------------------------------------------
C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD
C-----------------------------------------------------------------------
      NUI = INT(FNUL-DFNU) + 1
      NUI = MAX0(NUI,0)
C write (*,*) ' CBINU: call CBUNI..'
      CALL CBUNI(Z, FNU, KODE, NN, CY, NW, NUI, NLAST, FNUL, TOL, ELIM,
     * ALIM)
      IF (NW.LT.0) GO TO 130
      NZ = NZ + NW
      IF (NLAST.EQ.0) GO TO 120
      NN = NLAST
      GO TO 60
  120 CONTINUE
      RETURN
  130 CONTINUE
      NZ = -1
      IF(NW.EQ.(-2)) NZ=-2
      RETURN
      END
C *********
      DOUBLEPRECISION FUNCTION GAMLN(Z,IERR)
C***BEGIN PROLOGUE GAMLN
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5F
C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION
C***DESCRIPTION
C
C GAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS
C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE
C 10 DIGITS IN A WORD, RLN=DMAX1(-DLOG10(R1MACH(4)),0.5E-18)
C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
C
C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
C VALUES IS USED FOR SPEED OF EXECUTION.
C
C DESCRIPTION OF ARGUMENTS
C
C INPUT
C Z - DOUBLEPRECISION ARGUMENT, Z.GT.0.0E0
C
C OUTPUT
C GAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
C IERR=1, Z.LE.0.0E0, NO COMPUTATION
C
C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF DOUBLECOMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C***ROUTINES CALLED I1MACH,R1MACH
C***END PROLOGUE GAMLN
C
      INTEGER I, I1M, K, MZ, NZ, IERR, I1MACH
      DOUBLEPRECISION
     1 CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, T1, WDTOL, Z,
     * ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ
      DOUBLEPRECISION
     1 R1MACH
      DIMENSION CF(22), GLN(100)
C LNGAMMA(N), N=1,100
      DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7),
     1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14),
     2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20),
     3 GLN(21), GLN(22)/
     4 0.00000000000000000E+00, 0.00000000000000000E+00,
     5 6.93147180559945309E-01, 1.79175946922805500E+00,
     6 3.17805383034794562E+00, 4.78749174278204599E+00,
     7 6.57925121201010100E+00, 8.52516136106541430E+00,
     8 1.06046029027452502E+01, 1.28018274800814696E+01,
     9 1.51044125730755153E+01, 1.75023078458738858E+01,
     A 1.99872144956618861E+01, 2.25521638531234229E+01,
     B 2.51912211827386815E+01, 2.78992713838408916E+01,
     C 3.06718601060806728E+01, 3.35050734501368889E+01,
     D 3.63954452080330536E+01, 3.93398841871994940E+01,
     E 4.23356164607534850E+01, 4.53801388984769080E+01/
      DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28),
     1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34),
     2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40),
     3 GLN(41), GLN(42), GLN(43), GLN(44)/
     4 4.84711813518352239E+01, 5.16066755677643736E+01,
     5 5.47847293981123192E+01, 5.80036052229805199E+01,
     6 6.12617017610020020E+01, 6.45575386270063311E+01,
     7 6.78897431371815350E+01, 7.12570389671680090E+01,
     8 7.46582363488301644E+01, 7.80922235533153106E+01,
     9 8.15579594561150372E+01, 8.50544670175815174E+01,
     A 8.85808275421976788E+01, 9.21361756036870925E+01,
     B 9.57196945421432025E+01, 9.93306124547874269E+01,
     C 1.02968198614513813E+02, 1.06631760260643459E+02,
     D 1.10320639714757395E+02, 1.14034211781461703E+02,
     E 1.17771881399745072E+02, 1.21533081515438634E+02/
      DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50),
     1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56),
     2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62),
     3 GLN(63), GLN(64), GLN(65), GLN(66)/
     4 1.25317271149356895E+02, 1.29123933639127215E+02,
     5 1.32952575035616310E+02, 1.36802722637326368E+02,
     6 1.40673923648234259E+02, 1.44565743946344886E+02,
     7 1.48477766951773032E+02, 1.52409592584497358E+02,
     8 1.56360836303078785E+02, 1.60331128216630907E+02,
     9 1.64320112263195181E+02, 1.68327445448427652E+02,
     A 1.72352797139162802E+02, 1.76395848406997352E+02,
     B 1.80456291417543771E+02, 1.84533828861449491E+02,
     C 1.88628173423671591E+02, 1.92739047287844902E+02,
     D 1.96866181672889994E+02, 2.01009316399281527E+02,
     E 2.05168199482641199E+02, 2.09342586752536836E+02/
      DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72),
     1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78),
     2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84),
     3 GLN(85), GLN(86), GLN(87), GLN(88)/
     4 2.13532241494563261E+02, 2.17736934113954227E+02,
     5 2.21956441819130334E+02, 2.26190548323727593E+02,
     6 2.30439043565776952E+02, 2.34701723442818268E+02,
     7 2.38978389561834323E+02, 2.43268849002982714E+02,
     8 2.47572914096186884E+02, 2.51890402209723194E+02,
     9 2.56221135550009525E+02, 2.60564940971863209E+02,
     A 2.64921649798552801E+02, 2.69291097651019823E+02,
     B 2.73673124285693704E+02, 2.78067573440366143E+02,
     C 2.82474292687630396E+02, 2.86893133295426994E+02,
     D 2.91323950094270308E+02, 2.95766601350760624E+02,
     E 3.00220948647014132E+02, 3.04686856765668715E+02/
      DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94),
     1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/
     2 3.09164193580146922E+02, 3.13652829949879062E+02,
     3 3.18152639620209327E+02, 3.22663499126726177E+02,
     4 3.27185287703775217E+02, 3.31717887196928473E+02,
     5 3.36261181979198477E+02, 3.40815058870799018E+02,
     6 3.45379407062266854E+02, 3.49954118040770237E+02,
     7 3.54539085519440809E+02, 3.59134205369575399E+02/
C COEFFICIENTS OF ASYMPTOTIC EXPANSION
      DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8),
     1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15),
     2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/
     3 8.33333333333333333E-02, -2.77777777777777778E-03,
     4 7.93650793650793651E-04, -5.95238095238095238E-04,
     5 8.41750841750841751E-04, -1.91752691752691753E-03,
     6 6.41025641025641026E-03, -2.95506535947712418E-02,
     7 1.79644372368830573E-01, -1.39243221690590112E+00,
     8 1.34028640441683920E+01, -1.56848284626002017E+02,
     9 2.19310333333333333E+03, -3.61087712537249894E+04,
     A 6.91472268851313067E+05, -1.52382215394074162E+07,
     B 3.82900751391414141E+08, -1.08822660357843911E+10,
     C 3.47320283765002252E+11, -1.23696021422692745E+13,
     D 4.88788064793079335E+14, -2.13203339609193739E+16/
C
C LN(2*PI)
      DATA CON / 1.83787706640934548E+00/
C
C***FIRST EXECUTABLE STATEMENT GAMLN
      IERR=0
      IF (Z.LE.0.0E0) GO TO 70
      IF (Z.GT.101.0E0) GO TO 10
      NZ = INT(Z)
      FZ = Z - FLOAT(NZ)
      IF (FZ.GT.0.0E0) GO TO 10
      IF (NZ.GT.100) GO TO 10
      GAMLN = GLN(NZ)
      RETURN
   10 CONTINUE
      WDTOL = R1MACH(4)
      WDTOL = DMAX1(WDTOL,DBLE(0.5E-18))
      I1M = I1MACH(11)
      RLN = R1MACH(5)*FLOAT(I1M)
      FLN = DMIN1(RLN,DBLE(20.0E0))
      FLN = DMAX1(FLN,DBLE(3.0E0))
      FLN = FLN - 3.0E0
      ZM = 1.8000E0 + 0.3875E0*FLN
      MZ = INT(ZM) + 1
      ZMIN = FLOAT(MZ)
      ZDMY = Z
      ZINC = 0.0E0
      IF (Z.GE.ZMIN) GO TO 20
      ZINC = ZMIN - FLOAT(NZ)
      ZDMY = Z + ZINC
   20 CONTINUE
      ZP = 1.0E0/ZDMY
      T1 = CF(1)*ZP
      S = T1
      IF (ZP.LT.WDTOL) GO TO 40
      ZSQ = ZP*ZP
      TST = T1*WDTOL
      DO 30 K=2,22
        ZP = ZP*ZSQ
        TRM = CF(K)*ZP
        IF (ABS(TRM).LT.TST) GO TO 40
        S = S + TRM
   30 CONTINUE
   40 CONTINUE
      IF (ZINC.NE.0.0E0) GO TO 50
      TLG = DLOG(Z)
      GAMLN = Z*(TLG-1.0E0) + 0.5E0*(CON-TLG) + S
      RETURN
   50 CONTINUE
      ZP = 1.0E0
      NZ = INT(ZINC)
      DO 60 I=1,NZ
        ZP = ZP*(Z+FLOAT(I-1))
   60 CONTINUE
      TLG = DLOG(ZDMY)
      GAMLN = ZDMY*(TLG-1.0E0) - DLOG(ZP) + 0.5E0*(CON-TLG) + S
      RETURN
C
C
   70 CONTINUE
      IERR=1
      RETURN
      END
      SUBROUTINE CUCHK(Y, NZ, ASCLE, TOL)
C***BEGIN PROLOGUE CUCHK
C***REFER TO CSERI,CUOIK,CUNK1,CUNK2,CUNI1,CUNI2,CKSCL
C
C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN
C EXP(-ALIM)=ASCLE=1.0E+3*R1MACH(1)/TOL. THE TEST IS MADE TO SEE
C IF THE MAGNITUDE OF THE DOUBLEPRECISION OR IMAGINARY PART WOULD UNDER FLOW
C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED
C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE
C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE
C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED.
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE CUCHK
C
      DOUBLECOMPLEX Y
      DOUBLEPRECISION
     1 ASCLE, SS, ST, TOL, YR, YI
      INTEGER NZ
      NZ = 0
      YR = DBLE(Y)
      YI = DIMAG(Y)
      YR = ABS(YR)
      YI = ABS(YI)
      ST = DMIN1(YR,YI)
      IF (ST.GT.ASCLE) RETURN
      SS = DMAX1(YR,YI)
      ST=ST/TOL
      IF (SS.LT.ST) NZ = 1
      RETURN
      END
      SUBROUTINE CACAI(Z, FNU, KODE, MR, N, Y, NZ, RL, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CACAI
C***REFER TO CAIRY
C
C CACAI APPLIES THE ANALYTIC CONTINUATION FORMULA
C
C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
C MP=PI*MR*DCMPLX(0.0,1.0)
C
C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
C HALF Z PLANE FOR USE WITH CAIRY WHERE FNU=1/3 OR 2/3 AND N=1.
C CACAI IS THE SAME AS CACON WITH THE PARTS FOR LARGER ORDERS AND
C RECURRENCE REMOVED. A RECURSIVE CALL TO CACON CAN RESULT IF CACON
C IS CALLED FROM CAIRY.
C
C***ROUTINES CALLED CASYI,CBKNU,CMLRI,CSERI,CS1S2,R1MACH
C***END PROLOGUE CACAI
      DOUBLECOMPLEX
     1 CSGN, CSPN, C1, C2, Y, Z, ZN, CY
      DOUBLEPRECISION
     1 ALIM, ARG, ASCLE, AZ, CPN, DFNU, ELIM, FMR, FNU, PI, RL,
     * SGN, SPN, TOL, YY, R1MACH
      INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ
      DIMENSION Y(*), CY(2)
      DATA PI / 3.14159265358979324E0 /
      NZ = 0
      ZN = -Z
      AZ = ZABS(Z)
      NN = N
      DFNU = FNU + FLOAT(N-1)
      IF (AZ.LE.2.0E0) GO TO 10
      IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20
   10 CONTINUE
C-----------------------------------------------------------------------
C POWER SERIES FOR THE I FUNCTION
C-----------------------------------------------------------------------
      CALL CSERI(ZN, FNU, KODE, NN, Y, NW, TOL, ELIM, ALIM)
      GO TO 40
   20 CONTINUE
      IF (AZ.LT.RL) GO TO 30
C-----------------------------------------------------------------------
C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION
C-----------------------------------------------------------------------
      CALL CASYI(ZN, FNU, KODE, NN, Y, NW, RL, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 70
      GO TO 40
   30 CONTINUE
C-----------------------------------------------------------------------
C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION
C-----------------------------------------------------------------------
      CALL CMLRI(ZN, FNU, KODE, NN, Y, NW, TOL)
      IF(NW.LT.0) GO TO 70
   40 CONTINUE
C-----------------------------------------------------------------------
C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
C-----------------------------------------------------------------------
      CALL CBKNU(ZN, FNU, KODE, 1, CY, NW, TOL, ELIM, ALIM)
      IF (NW.NE.0) GO TO 70
      FMR = FLOAT(MR)
      SGN = -SIGN(PI,FMR)
C CSGN = DCMPLX(0.0E0,SGN)
      CSGN = (0.,1.)*SGN
      IF (KODE.EQ.1) GO TO 50
      YY = -DIMAG(ZN)
      CPN = COS(YY)
      SPN = SIN(YY)
      CSGN = CSGN*DCMPLX(CPN,SPN)
   50 CONTINUE
C-----------------------------------------------------------------------
C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
C WHEN FNU IS LARGE
C-----------------------------------------------------------------------
      INU = INT(FNU)
      ARG = (FNU-FLOAT(INU))*SGN
      CPN = COS(ARG)
      SPN = SIN(ARG)
      CSPN = DCMPLX(CPN,SPN)
      IF (MOD(INU,2).EQ.1) CSPN = -CSPN
      C1 = CY(1)
      C2 = Y(1)
      IF (KODE.EQ.1) GO TO 60
      IUF = 0
      ASCLE = 1.0E+3*R1MACH(1)/TOL
      CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
      NZ = NZ + NW
   60 CONTINUE
      Y(1) = CSPN*C1 + CSGN*C2
      RETURN
   70 CONTINUE
      NZ = -1
      IF(NW.EQ.(-2)) NZ=-2
      RETURN
      END
C ***********************************
      INTEGER FUNCTION I1MACH(I)
      INTEGER I
C***BEGIN PROLOGUE I1MACH
C***DATE WRITTEN 750101 (YYMMDD)
C***REVISION DATE 860501 (YYMMDD)
C***CATEGORY NO. R1
C***KEYWORDS MACHINE CONSTANTS
C***AUTHOR FOX, P. A., (BELL LABS)
C HALL, A. D., (BELL LABS)
C SCHRYER, N. L., (BELL LABS)
C***PURPOSE RETURN INTEGER MACHINE DEPENDENT CONSTANTS.
C***DESCRIPTION
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C THESE MACHINE CONSTANT ROUTINES MUST BE ACTIVATED FOR
C A PARTICULAR ENVIRONMENT.
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C I1MACH CAN BE USED TO OBTAIN MACHINE-DEPENDENT PARAMETERS
C FOR THE LOCAL MACHINE ENVIRONMENT. IT IS A FUNCTION
C SUBROUTINE WITH ONE (INPUT) ARGUMENT, AND CAN BE CALLED
C AS FOLLOWS, FOR EXAMPLE
C
C K = I1MACH(I)
C
C WHERE I=1,...,16. THE (OUTPUT) VALUE OF K ABOVE IS
C DETERMINED BY THE (INPUT) VALUE OF I. THE RESULTS FOR
C VARIOUS VALUES OF I ARE DISCUSSED BELOW.
C
C I/O UNIT NUMBERS.
C I1MACH( 1) = THE STANDARD INPUT UNIT.
C I1MACH( 2) = THE STANDARD OUTPUT UNIT.
C I1MACH( 3) = THE STANDARD PUNCH UNIT.
C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT.
C
C WORDS.
C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT.
C I1MACH( 6) = THE NUMBER OF CHARACTERS PER INTEGER STORAGE UNIT.
C
C INTEGERS.
C ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM
C
C SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
C
C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1.
C I1MACH( 7) = A, THE BASE.
C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS.
C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE.
C
C FLOATING-POINT NUMBERS.
C ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT,
C BASE-B FORM
C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C
C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T,
C 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX.
C I1MACH(10) = B, THE BASE.
C
C SINGLE-PRECISION
C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS.
C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E.
C I1MACH(13) = EMAX, THE LARGEST EXPONENT E.
C
C DOUBLE-PRECISION
C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS.
C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E.
C I1MACH(16) = EMAX, THE LARGEST EXPONENT E.
C
C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT,
C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY
C REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF
C I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY
C WITH THE LOCAL OPERATING SYSTEM.
C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
C***ROUTINES CALLED (NONE)
C***END PROLOGUE I1MACH
C
      INTEGER IMACH(16),OUTPUT
      EQUIVALENCE (IMACH(4),OUTPUT)
C
C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C DATA IMACH( 1) / 7 /
C DATA IMACH( 2) / 2 /
C DATA IMACH( 3) / 2 /
C DATA IMACH( 4) / 2 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 33 /
C DATA IMACH( 9) / Z1FFFFFFFF /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -256 /
C DATA IMACH(13) / 255 /
C DATA IMACH(14) / 60 /
C DATA IMACH(15) / -256 /
C DATA IMACH(16) / 255 /
C
C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 48 /
C DATA IMACH( 6) / 6 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 39 /
C DATA IMACH( 9) / O0007777777777777 /
C DATA IMACH(10) / 8 /
C DATA IMACH(11) / 13 /
C DATA IMACH(12) / -50 /
C DATA IMACH(13) / 76 /
C DATA IMACH(14) / 26 /
C DATA IMACH(15) / -50 /
C DATA IMACH(16) / 76 /
C
C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 48 /
C DATA IMACH( 6) / 6 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 39 /
C DATA IMACH( 9) / O0007777777777777 /
C DATA IMACH(10) / 8 /
C DATA IMACH(11) / 13 /
C DATA IMACH(12) / -50 /
C DATA IMACH(13) / 76 /
C DATA IMACH(14) / 26 /
C DATA IMACH(15) / -32754 /
C DATA IMACH(16) / 32780 /
C
C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C FOR FTN4
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6LOUTPUT /
C DATA IMACH( 5) / 60 /
C DATA IMACH( 6) / 10 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 48 /
C DATA IMACH( 9) / 00007777777777777777B /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 47 /
C DATA IMACH(12) / -929 /
C DATA IMACH(13) / 1070 /
C DATA IMACH(14) / 94 /
C DATA IMACH(15) / -929 /
C DATA IMACH(16) / 1069 /
C
C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C FOR FTN5
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / L"OUTPUT" /
C DATA IMACH( 5) / 60 /
C DATA IMACH( 6) / 10 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 48 /
C DATA IMACH( 9) / O"00007777777777777777" /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 47 /
C DATA IMACH(12) / -929 /
C DATA IMACH(13) / 1070 /
C DATA IMACH(14) / 94 /
C DATA IMACH(15) / -929 /
C DATA IMACH(16) / 1069 /
C
C MACHINE CONSTANTS FOR THE CRAY 1
C
C DATA IMACH( 1) / 100 /
C DATA IMACH( 2) / 101 /
C DATA IMACH( 3) / 102 /
C DATA IMACH( 4) / 101 /
C DATA IMACH( 5) / 64 /
C DATA IMACH( 6) / 8 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 63 /
C DATA IMACH( 9) / 777777777777777777777B /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 47 /
C DATA IMACH(12) / -8189 /
C DATA IMACH(13) / 8190 /
C DATA IMACH(14) / 94 /
C DATA IMACH(15) / -8099 /
C DATA IMACH(16) / 8190 /
C
C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C DATA IMACH( 1) / 11 /
C DATA IMACH( 2) / 12 /
C DATA IMACH( 3) / 8 /
C DATA IMACH( 4) / 10 /
C DATA IMACH( 5) / 16 /
C DATA IMACH( 6) / 2 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 15 /
C DATA IMACH( 9) / 32767 /
C DATA IMACH(10) / 16 /
C DATA IMACH(11) / 6 /
C DATA IMACH(12) / -64 /
C DATA IMACH(13) / 63 /
C DATA IMACH(14) / 14 /
C DATA IMACH(15) / -64 /
C DATA IMACH(16) / 63 /
C
C MACHINE CONSTANTS FOR THE HARRIS 220
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 0 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 24 /
C DATA IMACH( 6) / 3 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 23 /
C DATA IMACH( 9) / 8388607 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 23 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 38 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 43 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 6 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / O377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 63 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE HP 2100
C 3 WORD DOUBLE PRECISION OPTION WITH FTN4
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 4 /
C DATA IMACH( 4) / 1 /
C DATA IMACH( 5) / 16 /
C DATA IMACH( 6) / 2 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 15 /
C DATA IMACH( 9) / 32767 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 23 /
C DATA IMACH(12) / -128 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 39 /
C DATA IMACH(15) / -128 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE HP 2100
C 4 WORD DOUBLE PRECISION OPTION WITH FTN4
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 4 /
C DATA IMACH( 4) / 1 /
C DATA IMACH( 5) / 16 /
C DATA IMACH( 6) / 2 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 15 /
C DATA IMACH( 9) / 32767 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 23 /
C DATA IMACH(12) / -128 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 55 /
C DATA IMACH(15) / -128 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE HP 9000
C
      DATA IMACH( 1) / 5 /
      DATA IMACH( 2) / 6 /
      DATA IMACH( 3) / 6 /
      DATA IMACH( 4) / 7 /
      DATA IMACH( 5) / 32 /
      DATA IMACH( 6) / 4 /
      DATA IMACH( 7) / 2 /
      DATA IMACH( 8) / 32 /
      DATA IMACH( 9) / 2147483647 /
      DATA IMACH(10) / 2 /
      DATA IMACH(11) / 24 /
      DATA IMACH(12) / -126 /
      DATA IMACH(13) / 127 /
      DATA IMACH(14) / 53 /
      DATA IMACH(15) / -1015 /
      DATA IMACH(16) / 1017 /
C
C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND
C THE PERKIN ELMER (INTERDATA) 7/32.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 16 /
C DATA IMACH( 8) / 31 /
C DATA IMACH( 9) / Z7FFFFFFF /
C DATA IMACH(10) / 16 /
C DATA IMACH(11) / 6 /
C DATA IMACH(12) / -64 /
C DATA IMACH(13) / 63 /
C DATA IMACH(14) / 14 /
C DATA IMACH(15) / -64 /
C DATA IMACH(16) / 63 /
C
C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 5 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 5 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / "377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -128 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 54 /
C DATA IMACH(15) / -101 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 5 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 5 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / "377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -128 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 62 /
C DATA IMACH(15) / -128 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C 32-BIT INTEGER ARITHMETIC.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 5 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 31 /
C DATA IMACH( 9) / 2147483647 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 56 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C 16-BIT INTEGER ARITHMETIC.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 5 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 16 /
C DATA IMACH( 6) / 2 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 15 /
C DATA IMACH( 9) / 32767 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 56 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. FTN COMPILER
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 1 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / O377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -128 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 60 /
C DATA IMACH(15) / -1024 /
C DATA IMACH(16) / 1023 /
C
C MACHINE CONSTANTS FOR THE VAX 11/780
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 5 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 31 /
C DATA IMACH( 9) / 2147483647 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 56 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE ELXSI 6400
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 6 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 32 /
C DATA IMACH( 9) / 2147483647 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -126 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 53 /
C DATA IMACH(15) / -1022 /
C DATA IMACH(16) / 1023 /
C
C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR
C
C DATA IMACH( 1) / 1 /
C DATA IMACH( 2) / 1 /
C DATA IMACH( 3) / 0 /
C DATA IMACH( 4) / 1 /
C DATA IMACH( 5) / 16 /
C DATA IMACH( 6) / 2 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 15 /
C DATA IMACH( 9) / 32767 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 56 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /
C
C MACHINE CONSTANTS FOR THE IBM PC - MICROSOFT FORTRAN
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 6 /
C DATA IMACH( 4) / 0 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 31 /
C DATA IMACH( 9) / 2147483647 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -126 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 53 /
C DATA IMACH(15) / -1022 /
C DATA IMACH(16) / 1023 /
C
C MACHINE CONSTANTS FOR THE IBM PC - PROFESSIONAL FORTRAN
C AND LAHEY FORTRAN
C
C DATA IMACH( 1) / 4 /
C DATA IMACH( 2) / 7 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 0 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 31 /
C DATA IMACH( 9) / 2147483647 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -126 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 53 /
C DATA IMACH(15) / -1022 /
C DATA IMACH(16) / 1023 /
C
      INTEGER J
      DOUBLEPRECISION R1MACH
C***FIRST EXECUTABLE STATEMENT I1MACH
      IF (I .LT. 1 .OR. I .GT. 16) GO TO 10
C
      J= I
      IF ((I .GE. 11) .AND. (I .LE. 13)) THEN
         IF (R1MACH(4) .LT. 1.E-10) J= J+3
      ENDIF
      I1MACH=IMACH(J)
      RETURN
C *************
   10 CONTINUE
      WRITE(OUTPUT,9000)
 9000 FORMAT('1ERROR    1 IN I1MACH - I OUT OF BOUNDS ')
C
C CALL FDUMP
C
C
      STOP
      END
      DOUBLE PRECISION FUNCTION D1MACH(I)
      INTEGER I
C***BEGIN PROLOGUE D1MACH
C***DATE WRITTEN 750101 (YYMMDD)
C***REVISION DATE 860501 (YYMMDD)
C***CATEGORY NO. R1
C***KEYWORDS MACHINE CONSTANTS
C***AUTHOR FOX, P. A., (BELL LABS)
C HALL, A. D., (BELL LABS)
C SCHRYER, N. L., (BELL LABS)
C***PURPOSE RETURN DOUBLE PRECISION MACHINE DEPENDENT CONSTANTS.
C***DESCRIPTION
C
C D1MACH CAN BE USED TO OBTAIN MACHINE-DEPENDENT PARAMETERS
C FOR THE LOCAL MACHINE ENVIRONMENT. IT IS A FUNCTION
C SUBPROGRAM WITH ONE (INPUT) ARGUMENT, AND CAN BE CALLED
C AS FOLLOWS, FOR EXAMPLE
C
C D = D1MACH(I)
C
C WHERE I=1,...,5. THE (OUTPUT) VALUE OF D ABOVE IS
C DETERMINED BY THE (INPUT) VALUE OF I. THE RESULTS FOR
C VARIOUS VALUES OF I ARE DISCUSSED BELOW.
C
C DOUBLE-PRECISION MACHINE CONSTANTS
C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C D1MACH( 5) = LOG10(B)
C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
C***ROUTINES CALLED XERROR
C***END PROLOGUE D1MACH
C
      DOUBLEPRECISION R1MACH
C***FIRST EXECUTABLE STATEMENT D1MACH
      IF (I .LT. 1 .OR. I .GT. 5)
     1 CALL XERROR( 'D1MACH -- I OUT OF BOUNDS',25,1,2)
C
      D1MACH = R1MACH(I)
      RETURN
C
      END
C *************
      SUBROUTINE XERROR(MESS,NMESS,L1,L2)
      INTEGER NMESS,L1,L2
C
C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS
C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL
C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77
C ROUTINE.
C
      CHARACTER*(*) MESS
C
      INTEGER K,NR,KMIN,I,NN
C
      NN=NMESS/70
      NR=NMESS-70*NN
      IF(NR.NE.0) NN=NN+1
      K=1
      PRINT 900
  900 FORMAT(/)
      DO 10 I=1,NN
        KMIN=MIN0(K+69,NMESS)
        PRINT *, MESS(K:KMIN)
        K=K+70
   10 CONTINUE
      PRINT 900
      RETURN
      END
C *******
      SUBROUTINE FDUMP
C***BEGIN PROLOGUE FDUMP
C***DATE WRITTEN 790801 (YYMMDD)
C***REVISION DATE 850801 (YYMMDD)
C***CATEGORY NO. R3
C***KEYWORDS ERROR,XERROR PACKAGE
C***AUTHOR JONES, R. E., (SNLA)
C***PURPOSE SYMBOLIC DUMP (SHOULD BE LOCALLY WRITTEN).
C***DESCRIPTION
C
C ***NOTE*** MACHINE DEPENDENT ROUTINE
C FDUMP IS INTENDED TO BE REPLACED BY A LOCALLY WRITTEN
C VERSION WHICH PRODUCES A SYMBOLIC DUMP. FAILING THIS,
C IT SHOULD BE REPLACED BY A VERSION WHICH PRINTS THE
C SUBPROGRAM NESTING LIST. NOTE THAT THIS DUMP MUST BE
C PRINTED ON EACH OF UP TO FIVE FILES, AS INDICATED BY THE
C XGETUA ROUTINE. SEE XSETUA AND XGETUA FOR DETAILS.
C
C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C***REFERENCES (NONE)
C***ROUTINES CALLED (NONE)
C***END PROLOGUE FDUMP
C***FIRST EXECUTABLE STATEMENT FDUMP
      WRITE (*,*) ' fdump'
      STOP 'fdump'
      END
C ../lib/cjcy.f
      DOUBLECOMPLEX FUNCTION CJ(N, R, I)
      INTEGER N
      DOUBLEPRECISION R,I
      DOUBLEPRECISION C331,BESI0,BESI1,SIGN1
      EXTERNAL C331,BESI0,BESI1,SIGN1
C
      DOUBLEPRECISION RNULL,ONE
      IF ( (ABS(R*I) .GT. 1.E-7*(ABS(R)+ABS(I)))
     1 .OR. (N .GT. 1)
     2 .OR. (N .LT. 0)
     3 ) THEN
         WRITE (*,*) ' CJ: N,R,I',N,R,I
         CALL ErrorStop(' CJ: FALSCHE PARAMETER')
      ENDIF
C
      RNULL= 0.
      ONE= 1.
      IF (ABS(I) .GT. ABS(R)) THEN
         IF (N .EQ. 0) THEN
            CJ= BESI0(ABS(I))
         ELSE IF (N .EQ. 1) THEN
            CJ= DCMPLX( RNULL, BESI1(ABS(I))*SIGN1(ONE,I) )
C CJ= DCMPLX( rnull, BESI1(ABS(I))*I/ABS(I) )
         ENDIF
      ELSE
         IF (N .EQ. 0) THEN
            CJ= C331(ABS(R),1)
         ELSE IF (N .EQ. 1) THEN
            CJ= C331(ABS(R),3)*SIGN1(ONE,R)
C CJ= C331(ABS(R),3)*R/ABS(R)
         ENDIF
      ENDIF
      RETURN
      END
C ************************
      DOUBLECOMPLEX FUNCTION CY(N, R, I)
      INTEGER N
      DOUBLEPRECISION R,I
C
      DOUBLEPRECISION BESK0,BESK1,BESI0,BESI1,C331
      EXTERNAL BESK0,BESK1,BESI0,BESI1,C331
C
      DOUBLEPRECISION C,MUE,EPS,PI
      COMMON /KONST/ C,MUE,EPS,PI
      DOUBLEPRECISION RNULL,ONE,SIGN1
      EXTERNAL SIGN1
C
C WRITE (*,*) ' CY: N,R,I:',N,R,I
      IF ( (ABS(R*I) .GT. 1.E-7*(ABS(R)+ABS(I)))
     1 .OR. (N .GT. 1)
     2 .OR. (N .LT. 0)
     3 ) THEN
         WRITE (*,*) ' CY: N,R,I',N,R,I
         CALL ErrorStop(' CY: FALSCHE PARAMETER')
      ENDIF
C
      ONE= 1.
      IF (ABS(I) .GT. ABS(R)) THEN
         IF (N .EQ. 0) THEN
            CY= DCMPLX(
     1 -2. / PI * BESK0(ABS(I)),
     2 BESI0(ABS(I))
     3 )
         ELSE IF (N .EQ. 1) THEN
C CY= I/ABS(I)*DCMPLX(
            CY= SIGN1(ONE,I)*DCMPLX(
     1 -BESI1(ABS(I)),
     2 2. / PI * BESK1(ABS(I))
     3 )
         ENDIF
      ELSE
         IF (N .EQ. 0) THEN
            CY= C331(ABS(R),2)
         ELSE IF (N .EQ. 1) THEN
            CY= C331(ABS(R),4)*SIGN1(ONE,R)
C CY= C331(ABS(R),4)*R/ABS(R)
         ENDIF
      ENDIF
      RETURN
      END
C ../lib/c335.f
      SUBROUTINE C335(X,N1,A)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
C***********************************************************************
C
C*DOC,BEG. SUBROUTINE C335(X,N1,A)
C*DOC,INDEX
C UNTERPROGRAMM ZUR BERECHNUNG DER BESSELFUNKTIONEN 1.ART J(I,X)
C DER ORDNUNGEN I=0 ... N FUER EIN REELLES ARGUMENT X
C*DOC,SHORT
C
C PARAMETERBESCHREIBUNG:
C
C X - ARGUMENT DER ZU BERECHNENDEN BESSELFUNKTIONEN
C N1 - MAXIMALE ORDNUNG DER ZU BERECHNENDEN BESSELFUNKTIONEN + 1
C N1 DARF HOECHSTENS 201 SEIN.
C A - ARRAY DER LAENGE N1. BEIM RUECKSPRUNG ENTHAELT DAS ELEMENT
C A(I), I=1 ... N1, DIE BESSELFUNKTION J(I-1,X).
C
C DIE RELATIVE GENAUIGKEIT DER BERECHNETEN FUNKTIONSWERTE BETRAEGT
C MINDESTENS 1.0E-11, AUSSER IN DER NAEHE EINER NULLSTELLE. IN DER
C NAEHE EINER NULLSTELLE VON J(I,X) IST DIE ABSOLUTE GENAUIGKEIT IN
C ETWA SO GROSS WIE DIEJENIGE VON J(I+1,X) BZW. J(I-1,X).
C
C*DOC,LONG
C HINWEIS: BEI BETRAGSMAESSIG KLEINEM X DARF WEGEN DES VERWENDETEN
C REKURSIONSVERFAHRENS N1 NUR SO GROSS GEWAEHLT WERDEN,
C DASS (N/X)**N NICHT ZU EINEM OVERFLOW FUEHRT.
C
C*DOC,LONG
C HINWEIS: BEI FEHLERHAFTEM PARAMETER N1, D.H. FUER N1 KLEINER 1
C ODER N1 GROESSER 201, WIRD DAS PROGRAMM ABGEBROCHEN.
C
C BERECHNUNGSMETHODE:
C
C FUER ABS(X) KLEINERGLEICH 1.0E-12 WERDEN A(1)=1.0 UND ALLE ANDEREN
C A(I)=0.0 GESETZT. FALLS ABS(X) GROESSER ALS 1.0E-12 IST,WIRD
C FOLGENDERMASSEN VORGEGANGEN:
C AUSGEHEND VON DER REKURSIONSFORMEL
C J(I+1,X)=(2*I/X)*J(I,X)-J(I-1,X)
C ERHAELT MAN MIT G(K):=J(K,X)/J(K-1,X)
C Q1:=G(N)=1.0/(2*N/X-G(N+1)) .
C BEI FORTLAUFENDER SUBSTITUTION VON G(K) IN DEN RECHTEN TEIL DIESER
C GLEICHNUNG ERGIBT SICH EIN KETTENBRUCH, DER ENTSPRECHEND DER
C METHODE VON G.BLANCH (VGL. LITERATUR) ENTWICKELT WIRD.
C JE NACHDEM OB Q1 BETRAGSMAESSIG GROESSERGLEICH ODER KLEINER ALS
C 1.0 IST, WIRD AUSGEHEND VON DEN STARTWERTEN A(N1)=Q1 UND A(N)=1.0
C BZW. A(N1)=1.0 UND A(N)=1.0/Q1 MIT HILFE DER REKURSIONSFORMEL
C A(I)=(2*I/X)*A(I+1)-A(I+2)
C RUECKWAERTS DER VEKTOR A BERECHNET (A(I)=J(I-1,X)/J(N-1,X) BZW.
C A(I)=J(I-1,X)/J(N,X) ). NUN WIRD MIT HILFE VON C331 J(0,X) ODER
C J(1,X) BERECHNET, JE NACHDEM WELCHER VON DIESEN BEIDEN WERTEN
C BETRAGSMAESSIG GROESSER IST, UND DURCH VERGLEICH MIT A(1) BZW.
C A(2) DER ALLEN ELEMENTEN VON A GEMEINSAME FAKTOR F:=J(I-1,X)/A(I)
C BESTIMMT. NACH GLIEDWEISER MULTIPLIKATION VON A MIT F STEHEN IM
C VEKTOR A DIE ZU BERECHNENDEN FUNKTIONSWERTE.
C
C BENOETIGTE UNTERPROGRAMME: C331 L855
C
C LITERATUR: G.BLANCH, NUMERICAL EVALUATION OF CONTINUED
C FRACTIONS, SIAM REVIEW, VOL.6, NO. 4, OCTOBER 1964
C
C VERSION: 1 30.1.73
C
C BEARBEITER: K.-J. STUEKEN JANUAR 1973
C
C COPYRIGHT: TECHNISCHE UNIVERSITAET BERLIN
C
C***********************************************************************
C
      DOUBLEPRECISION C331
      EXTERNAL C331
      DIMENSION A(N1)
C*DOC,END
      COMMON /RICOM/ AA(184),A0,A1,A2,B0,B1,B2,F,I,J,K,L,Q0,Q1,XX,Y,Z
C LIBRARY STATISTICS:
C CALL ZZZLSF (7HSOFT72 )
      IF(N1.LT.1.OR.N1.GT.201) CALL L855('   2','C335')
      IF(N1-2) 11,10,8
    8 IF(ABS(X).GT.1.0E-12) GOTO 12
      A(1)=1.0
      DO 7 I=2,N1
    7 A(I)=0.0
      RETURN
   10 A(2)=C331(X,3)
   11 A(1)=C331(X,1)
      RETURN
C
C BERECHNUNG VON J(N,X)/J(N-1,X) MIT HILFE EINES KETTENBRUCHS
   12 XX=2.0/X
      Z=FLOAT(N1)*XX
      Y=Z-XX
      A0=0.0
      B0=1.0
      A1=1.0
      B1=Y
      Q1=1.0/Y
    1 A2=Z*A1-A0
      B2=Z*B1-B0
      Q0=Q1
      Q1=A2/B2
      Z=Z+XX
      A0=A1
      B0=B1
      A1=A2
      B1=B2
      IF(ABS((Q1-Q0)/Q1)-1.E-13) 2,1,1
C
C RUECKWAERTSREKURSION
    2 L=N1
      K=L-1
      J=K-1
      IF(ABS(Q1).LT.1.0) GOTO 15
      A(L)=1.0
      A(K)=1.0/Q1
      GOTO 16
   15 A(L)=Q1
      A(K)=1.0
   16 DO 3 I=3,N1
      Y=Y-XX
      A(J)=Y*A(K)-A(L)
      L=K
      K=J
    3 J=J-1
C
C BESTIMMUNG DES GEMEINSAMEN FAKTORS F
      IF(ABS(A(1)).GT.ABS(A(2))) GOTO 20
      Y=C331(X,3)
      F=Y/A(2)
      A(2)=Y
      A(1)=F*A(1)
      GOTO 21
   20 Y=C331(X,1)
      F=Y/A(1)
      A(1)=Y
      A(2)=F*A(2)
C
C MULTIPLIKATION DES VEKTORS A MIT F
   21 DO 4 I=3,N1
    4 A(I)=F*A(I)
      RETURN
      END
C ../lib/c261.f
      SUBROUTINE C261(X,F,FCT,XLI,XRI,EPS,IUNT,IEND,IER)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      DOUBLEPRECISION FCT
      EXTERNAL FCT
C
C***********************************************************************
C
C*DOC,BEG. SUBROUTINE C261(X,F,FCT,XLI,XRI,EPS,IUNT,IEND,IER)
C*DOC,INDEX
C BERECHNUNG VON ALLGEMEINEN NICHTLINEAREN GLEICHUNGEN DER FORM
C FCT(X)=0 DURCH MUELLER"S ITERATIONSMETHODE.
C*DOC,SHORT
C
C PARAMETERBESCHREIBUNG:
C
C EINGABEPARAMETER:
C
C FCT - NAME DER EXTERNEN FUNKTION, DIE VOM BENUTZER
C GESCHRIEBEN WERDEN MUSS.
C
C XLI - LINKE GRENZE
C
C XRI - RECHTE GRENZE
C
C EPS - GENAUIGKEITSSCHRANKE
C
C IUNT - ANZAHL DER UNTERTEILUNGEN, DIE VORGENOMMEN WERDEN
C SOLLEN, FALLS FCT(XLI) UND FCT(XRI) DAS GLEICHE
C VORZEICHEN HABEN, UM UNGLEICHEIT DER VORZEICHEN
C ZU ERREICHEN.
C
C IEND - MAXIMALE ANZAHL DER ITERATIONSSCHRITTE
C
C
C AUSGABEPARAMETER:
C
C X - LOESUNG DER GLEICHUNG
C
C F - FUNKTIONSWERT AN DER STELLE X.
C
C IER - FEHLERCODE
C =0 KEIN FEHLER
C =1 KEINE KONVERGENZ NACH IEND ITERATIONSSCHRITTEN
C =2 UNGLEICHHEIT DER VORZEICHEN KONNTE AUCH NACH IUNT
C UNTERTEILUNGEN NICHT ERREICHT WERDEN.
C
C*DOC,LONG
C HINWEISE:
C FCT ERFORDERT EIN EXTERNAL-STATEMENT IM AUFRUFENDEN PROGRAMM.
C MUELLER"S ITERATIONS-METHODE SETZT UNGLEICHHEIT DER VORZEICHEN
C DER LINKEN UND RECHTEN FUNKTIONSWERTE VORAUS. DAS PROGRAMM
C LAESST ABER AUCH VORZEICHENGLEICHHEIT ZU. IN DIESEM FALLE KOMMT
C DER PARAMETER IUNT ZUM TRAGEN.
C DAS PROGRAMM WURDE MIT GERINGFUEGIGEN AENDERUNGEN AUS DER
C IBM-PROGRAMMBIBLIOTHEK SSP UEBERNOMMEN.
C
C METHODE:
C DIE GLEICHUNG FCT(X)=0 WIRD MITTELS MUELLER"S ITERATIONSMETHODE
C DURCH SUKZESSIVE BISECTION UND INVERSE PARABOLISCHE INTERPOLATION
C BEGINNEND AN DEN ANFANGSGRENZEN XLI UND XRI, GELOEST. DIE
C KONVERGENZ IST QUADRATISCH, FALLS DIE ABLEITUNG VON FCT(X) AN DER
C NULLSTELLE X UNGLEICH 0 IST. EIN ITERATIONSSCHRITT ERFORDERT ZWEI
C AUSWERTUNGEN VON FCT(X).
C
C LITERATUR:
C SSP, SEITE 217-218 (RTMI)
C BIT, VOL. 3 (1963) SEITE 205-206 (KRISTIANSEN)
C
C BENOETIGTE UNTERPROGRAMME: L855
C DIE FUNCTION FCT(X) MUSS VOM BENUTZER GESCHRIEBEN WERDEN.
C
C VERSION: 1 12/09/73
C
C BEARBEITER: U. CHRISTOFZIK SEPTEMBER 1973
C
C COPYRIGHT: TECHNISCHE UNIVERSITAET BERLIN
C
C***********************************************************************
C
C*DOC,END
      DOUBLEPRECISION SIGN1,ONE
      EXTERNAL SIGN1
C LIBRARY STATISTICS:
C CALL ZZZLSF (7HSOFT72 )
C WRITE (0,*) ' c261: xli,xri:',XLI,XRI
      IF(XRI-XLI.LE.0.) CALL L855(' 4/5','C261')
      IF(EPS.LE.0.) CALL L855('   6','C261')
      IF(IEND.LE.0) CALL L855('   8','C261')
C
C PREPARE ITERATION
      ONE= 1.
      IER=0
      XL=XLI
      XR=XRI
      X=XL
      TOL=X
      F=FCT(TOL)
      IF(F)1,16,1
    1 FL=F
      X=XR
      TOL=X
      F=FCT(TOL)
      IF(F)2,16,2
    2 FR=F
      IF(SIGN1(ONE,FL)+SIGN1(ONE,FR))25,3,25
C IF(FL/abs(fl)+FR/abs(fr))25,3,25
   25 IF(IUNT.LE.0) CALL L855('   7','C261')
      DX=(XR-XL)/IUNT
      X=XL
      DO 26 I=1,IUNT
      X=X+DX
      F=FCT(X)
      IF(ABS(F).LE.EPS)GOTO 16
      IF(F)28,16,28
   28 CONTINUE
      IF(SIGN1(ONE,FL)+SIGN1(ONE,F))26,27,26
C IF(FL/abs(fl)+F/abs(f))26,27,26
   26 CONTINUE
      GOTO 30
   27 FR=F
      XR=X
C
C BASIC ASSUMPTION FL*FR LESS THAN 0 IS SATISFIED.
C GENERATE TOLERANCE FOR FUNCTION VALUES.
    3 I=0
      TOLF=100.*EPS
C
C
C START ITERATION LOOP
    4 I=I+1
C
C START BISECTION LOOP
      DO 13 K=1,IEND
      X=.5*(XL+XR)
      TOL=X
      F=FCT(TOL)
      IF(F)5,16,5
    5 CONTINUE
      IF(SIGN1(ONE,F)+SIGN1(ONE,FR))7,6,7
C IF(F/abs(f)+FR/abs(fr))7,6,7
C
C INTERCHANGE XL AND XR IN ORDER TO GET THE SAME SIGN IN F AND FR
    6 TOL=XL
      XL=XR
      XR=TOL
      TOL=FL
      FL=FR
      FR=TOL
    7 TOL=F-FL
      A=F*TOL
      A=A+A
      IF(A-FR*(FR-FL))8,9,9
    8 IF(I-IEND)17,17,9
    9 XR=X
      FR=F
C
C TEST ON SATISFACTORY ACCURACY IN BISECTION LOOP
      TOL=EPS
      A=ABS(XR)
      IF(A-1.)11,11,10
   10 TOL=TOL*A
   11 IF(ABS(XR-XL)-TOL)12,12,13
   12 IF(ABS(FR-FL)-TOLF)14,14,13
   13 CONTINUE
C END OF BISECTION LOOP
C
C NO CONVERGENCE AFTER IEND ITERATION STEPS FOLLOWED BY IEND
C SUCCESSIVE STEPS OF BISECTION OR STEADILY INCREASING FUNCTION
C VALUES AT RIGHT BOUNDS. ERROR RETURN.
      IER=1
   14 IF(ABS(FR)-ABS(FL))16,16,15
   15 X=XL
      F=FL
   16 RETURN
C
C COMPUTATION OF ITERATED X-VALUE BY INVERSE PARABOLIC INTERPOLATION
   17 A=FR-F
      DX=(X-XL)*FL*(1.+F*(A-TOL)/(A*(FR-FL)))/TOL
      XM=X
      FM=F
      X=XL-DX
      TOL=X
      F=FCT(TOL)
      IF(F)18,16,18
C
C TEST ON SATISFACTORY ACCURACY IN ITERATION LOOP
   18 TOL=EPS
      A=ABS(X)
      IF(A-1.)20,20,19
   19 TOL=TOL*A
   20 IF(ABS(DX)-TOL)21,21,22
   21 IF(ABS(F)-TOLF)16,16,22
C
C PREPARATION OF NEXT BISECTION LOOP
   22 CONTINUE
      IF(SIGN1(ONE,F)+SIGN1(ONE,FL))24,23,24
C IF(F/abs(f)+FL/abs(fl))24,23,24
   23 XR=X
      FR=F
      GO TO 4
   24 XL=X
      FL=F
      XR=XM
      FR=FM
      GO TO 4
C END OF ITERATION LOOP
C
C
C ERROR RETURN IN CASE OF WRONG INPUT DATA
   30 IER=2
      RETURN
      END
C ../lib/besik.f
      DOUBLEPRECISION FUNCTION EBESI0(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      EBESI0= BESIK(1,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION BESI0(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      BESI0= BESIK(2,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION EBESI1(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      EBESI1= BESIK(3,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION BESI1(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      BESI1= BESIK(4,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION EBESK0(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      EBESK0= BESIK(5,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION BESK0(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      BESK0= BESIK(6,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION EBESK1(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      EBESK1= BESIK(7,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION BESK1(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      BESK1= BESIK(8,X)
      RETURN
      END
      DOUBLEPRECISION FUNCTION BESIK(KEY,X)
      IMPLICIT DOUBLEPRECISION (A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C CERN C313
      LOGICAL L,E
C
      IF (KEY .EQ. 1) GOTO 110 !! EBESI0
      IF (KEY .EQ. 2) GOTO 120 !! BESI0
      IF (KEY .EQ. 3) GOTO 130 !! EBESI1
      IF (KEY .EQ. 4) GOTO 140 !! BESI1
      IF (KEY .EQ. 5) GOTO 150 !! EBESK0
      IF (KEY .EQ. 6) GOTO 160 !! BESK0
      IF (KEY .EQ. 7) GOTO 170 !! EBESK1
      IF (KEY .EQ. 8) GOTO 180 !! BESK1
      CALL ErrorStop('BESIK')
C
  110 CONTINUE
C ENTRY EBESI0
      E=.TRUE.
      GO TO 1
  120 CONTINUE
C ENTRY BESI0(X)
      E=.FALSE.
    1 L=.TRUE.
      V=ABS(X)
      IF(V .GE. 8.0) GO TO 4
    8 F=0.0625*X**2-2.0
      A = 0.000000000000002
      B = F * A + 0.000000000000120
      A = F * B - A + 0.000000000006097
      B = F * A - B + 0.000000000268828
      A = F * B - A + 0.000000010169727
      B = F * A - B + 0.000000326091051
      A = F * B - A + 0.000008738315497
      B = F * A - B + 0.000192469359688
      A = F * B - A + 0.003416331766012
      B = F * A - B + 0.047718748798174
      A = F * B - A + 0.509493365439983
      B = F * A - B + 4.011673760179349
      A = F * B - A + 22.274819242462231
      B = F * A - B + 82.489032744024100
      A = F * B - A + 190.494320172742844
      A = F * A - B + 255.466879624362167
      BESIK=0.5*(A-B)
      IF(L .AND. E) BESIK=EXP(-V)*BESIK
      IF(L) RETURN
      A = + 0.000000000000003
      B = F * A + 0.000000000000159
      A = F * B - A + 0.000000000007658
      B = F * A - B + 0.000000000318588
      A = F * B - A + 0.000000011281211
      B = F * A - B + 0.000000335195256
      A = F * B - A + 0.000008216025940
      B = F * A - B + 0.000162708379043
      A = F * B - A + 0.002536308188086
      B = F * A - B + 0.030080722420512
      A = F * B - A + 0.259084432434900
      B = F * A - B + 1.511535676029228
      A = F * B - A + 5.283632866873920
      B = F * A - B + 8.005368868700334
      A = F * B - A - 4.563433586448395
      A = F * A - B - 21.057660177402440
      BESIK=-LOG(0.125*X)*BESIK+0.5*(A-B)
      IF(E) BESIK=EXP(X)*BESIK
      RETURN
    4 F=32.0/V-2.0
      B = - 0.000000000000001
      A = F * B - 0.000000000000001
      B = F * A - B + 0.000000000000004
      A = F * B - A + 0.000000000000010
      B = F * A - B - 0.000000000000024
      A = F * B - A - 0.000000000000104
      B = F * A - B + 0.000000000000039
      A = F * B - A + 0.000000000000966
      B = F * A - B + 0.000000000001800
      A = F * B - A - 0.000000000004497
      B = F * A - B - 0.000000000033127
      A = F * B - A - 0.000000000078957
      B = F * A - B + 0.000000000029802
      A = F * B - A + 0.000000001238425
      B = F * A - B + 0.000000008513091
      A = F * B - A + 0.000000056816966
      B = F * A - B + 0.000000513587727
      A = F * B - A + 0.000007247591100
      B = F * A - B + 0.000172700630778
      A = F * B - A + 0.008445122624921
      A = F * A - B + 2.016558410917480
      BESIK=0.199471140200717*(A-B)/SQRT(V)
      IF(E) RETURN
      BESIK=EXP(V)*BESIK
      RETURN
  130 CONTINUE
C ENTRY EBESI1(X)
      E=.TRUE.
      GO TO 2
  140 CONTINUE
C ENTRY BESI1(X)
      E=.FALSE.
    2 L=.TRUE.
      V=ABS(X)
      IF(V .GE. 8.0) GO TO 3
    7 F=0.0625*X**2-2.0
      A = + 0.000000000000001
      B = F * A + 0.000000000000031
      A = F * B - A + 0.000000000001679
      B = F * A - B + 0.000000000079291
      A = F * B - A + 0.000000003227617
      B = F * A - B + 0.000000111946285
      A = F * B - A + 0.000003264138122
      B = F * A - B + 0.000078756785754
      A = F * B - A + 0.001543019015627
      B = F * A - B + 0.023993079147841
      A = F * B - A + 0.287855511804672
      B = F * A - B + 2.571459906347755
      A = F * B - A + 16.334550552522066
      B = F * A - B + 69.395917633734448
      A = F * B - A + 181.312616040570265
      A = F * A - B + 259.890237806477292
      BESIK=0.0625*(A-B)*X
      IF(L .AND. E) BESIK=EXP(-V)*BESIK
      IF(L) RETURN
      A = + 0.000000000000001
      B = F * A + 0.000000000000042
      A = F * B - A + 0.000000000002163
      B = F * A - B + 0.000000000096660
      A = F * B - A + 0.000000003696783
      B = F * A - B + 0.000000119367971
      A = F * B - A + 0.000003202510692
      B = F * A - B + 0.000070010627855
      A = F * B - A + 0.001217056994516
      B = F * A - B + 0.016300049289816
      A = F * B - A + 0.161074301656148
      B = F * A - B + 1.101461993004852
      A = F * B - A + 4.666387026862842
      B = F * A - B + 9.361617831395389
      A = F * B - A - 1.839239224286199
      A = F * A - B - 26.688095480862668
      BESIK=LOG(0.125*X)*BESIK+1.0/X-0.0625*(A-B)*X
      IF(E) BESIK=EXP(X)*BESIK
      RETURN
    3 F=32.0/V-2.0
      B = + 0.000000000000001
      A = F * B + 0.000000000000001
      B = F * A - B - 0.000000000000005
      A = F * B - A - 0.000000000000010
      B = F * A - B + 0.000000000000026
      A = F * B - A + 0.000000000000107
      B = F * A - B - 0.000000000000053
      A = F * B - A - 0.000000000001024
      B = F * A - B - 0.000000000001804
      A = F * B - A + 0.000000000005103
      B = F * A - B + 0.000000000035408
      A = F * B - A + 0.000000000081531
      B = F * A - B - 0.000000000047563
      A = F * B - A - 0.000000001401141
      B = F * A - B - 0.000000009613873
      A = F * B - A - 0.000000065961142
      B = F * A - B - 0.000000629724239
      A = F * B - A - 0.000009732146728
      B = F * A - B - 0.000277205360764
      A = F * B - A - 0.024467442963276
      A = F * A - B + 1.951601204652572
      BESIK=0.199471140200717*(A-B)/SQRT(V)
      IF(X .LT. 0.0) BESIK=-BESIK
      IF(E) RETURN
      BESIK=EXP(V)*BESIK
      RETURN
  150 CONTINUE
C ENTRY EBESK0(X)
      E=.TRUE.
      GO TO 11
  160 CONTINUE
C ENTRY BESK0(X)
      E=.FALSE.
   11 IF(X .LE. 0.0) GO TO 9
      L=.FALSE.
      V=X
      IF(X .LT. 5.0) GO TO 8
      F=20.0/X-2.0
      A = - 0.000000000000002
      B = F * A + 0.000000000000011
      A = F * B - A - 0.000000000000079
      B = F * A - B + 0.000000000000581
      A = F * B - A - 0.000000000004580
      B = F * A - B + 0.000000000039044
      A = F * B - A - 0.000000000364547
      B = F * A - B + 0.000000003792996
      A = F * B - A - 0.000000045047338
      B = F * A - B + 0.000000632575109
      A = F * B - A - 0.000011106685197
      B = F * A - B + 0.000269532612763
      A = F * B - A - 0.011310504646928
      A = F * A - B + 1.976816348461652
      BESIK=0.626657068657750*(A-B)/SQRT(X)
      IF(E) RETURN
      Z=BESIK
      BESIK=0.
      IF(X .LT. 180.) BESIK=EXP(-X)*Z
      RETURN
  170 CONTINUE
C ENTRY EBESK1(X)
      E=.TRUE.
      GO TO 12
  180 CONTINUE
C ENTRY BESK1(X)
      E=.FALSE.
   12 IF(X .LE. 0.0) GO TO 9
      L=.FALSE.
      V=X
      IF(X .LT. 5.0) GO TO 7
      F=20.0/X-2.0
      A = + 0.000000000000002
      B = F * A - 0.000000000000013
      A = F * B - A + 0.000000000000089
      B = F * A - B - 0.000000000000663
      A = F * B - A + 0.000000000005288
      B = F * A - B - 0.000000000045757
      A = F * B - A + 0.000000000435417
      B = F * A - B - 0.000000004645555
      A = F * B - A + 0.000000057132218
      B = F * A - B - 0.000000845172048
      A = F * B - A + 0.000016185063810
      B = F * A - B - 0.000468475028167
      A = F * B - A + 0.035465291243331
      A = F * A - B + 2.071901717544716
      BESIK=0.626657068657750*(A-B)/SQRT(X)
      IF(E) RETURN
      Z=BESIK
      BESIK=0.
      IF(X .LT. 180.) BESIK=EXP(-X)*Z
      RETURN
    9 BESIK=0.
      PRINT 100,X
  100 FORMAT(1X,36HBESIK ... NON-POSITIVE ARGUMENT X = ,E15.4)
      RETURN
      END
C ../lib/c331.f
      DOUBLEPRECISION FUNCTION C331(X,KEY)
      IMPLICIT DOUBLEPRECISION (A-H, O-Z)
      INTEGER KEY
C/*
C***********************************************************************
C
C*DOC,BEG. FUNCTION C331(X,KEY)
C*DOC,INDEX
C     FUNKTIONSUNTERPROGRAMM ZUR BERECHNUNG DER BESSELFUNKTIONEN
C     J UND Y DER ORDNUNG 0 UND 1 FUER REELLES ARGUMENT
C*DOC,SHORT
C
C     PARAMETERBESCHREIBUNG:
C
C     X   - ARGUMENT ZU BERECHNENDEN FUNKTION. X MUSS FUER KEY=2 ODER
C           KEY=4 GROESSER ALS NULL SEIN.
C     KEY - STEUERPARAMETER. ES WIRD BERECHNET FUER
C           KEY=1: BESSELFUNKTION 1.ART (J) DER ORDNUNG 0
C           KEY=2: BESSELFUNKTION 2.ART (Y) DER ORDNUNG 0
C           KEY=3: BESSELFUNKTION 1.ART (J) DER ORDNUNG 1
C           KEY=4: BESSELFUNKTION 2.ART (Y) DER ORDNUNG 1
C
C     DIE RELATIVE GENAUIGKEIT DER BERECHNETEN FUNKTIONSWERTE IST
C     BESSER ALS 1.0E-12, FALLS X NICHT IN UNMITTELBARER NAEHE EINER
C     NULLSTELLE DER ZU BERECHNENDEN FUNKTION LIEGT.
C
C*DOC,LONG
C     HINWEIS: BEI FEHLERHAFTEN PARAMETERN, D.H. FUER X KLEINERGLEICH
C              0.0 BEI KEY=2 ODER KEY=4 UND FUER KEY KLEINER 1 UND KEY
C              GROESSER 4 WIRD DAS PROGRAMM ABGEBROCHEN.
C
C     BERECHNUNGSMETHODE:
C
C     DIE BESSELFUNKTIONEN WERDEN MIT HILFE EINER TSCHEBYSCHEFF-
C     APPROXIMATION BERECHNET, DEREN METHODE UND KOEFFIZIENTEN DER
C     ANGEGEBENEN LITERATUR ENTNOMMEN SIND.
C
C     BENOETIGTE UNTERPROGRAMME:   L855
C
C     LITERATUR: C.W.CLENSHAW,  CHEBYSHEV SERIES FOR MATH. FUNCTIONS,
C                     MATH.TABLES,VOL.5,NAT.PHYS.LAB.,LONDON 1962
C                CERN-PROGRAMM C321
C
C     VERSION:  1                                11.1.73
C
C     BEARBEITER:   K.-J.  STUEKEN                     JANUAR 1973
C
C     COPYRIGHT:  TECHNISCHE UNIVERSITAET  BERLIN
C
C***********************************************************************
C
C*DOC,END
C */
      LOGICAL AA
C COMMON /RICOM/ A,AA,B,COSXI,F,P,Q,SINXI,W,XI,XX,Z,ZZ(188)
C LIBRARY STATISTICS:
C CALL ZZZLSF (7HSOFT72 )
C
C write (*,*) ' c331: x,key:',x,key
      IF (KEY .LT. 1 .OR. KEY .GT. 4) CALL L855('   2','C331')
      AA= KEY .EQ. 2 .OR. KEY .EQ. 4
      IF (AA .AND. X .LE. 0.0) THEN
         WRITE (0,*) ' c331: key,x',KEY,X
                                      CALL L855('   1','C331')
      ENDIF
C
      XX= ABS(X)
      IF (XX .GT. 8.0) GOTO 3
C
C ARGUMENT X BETRAGSMAESSIG KLEINERGLEICH 8.0
      Z=0.125*X
      F=Z+Z
      F=F*F-2.0
      IF(KEY .GT. 2) GOTO 1
C
C BERECHNUNG VON J0
      B = + 0.0000000000000413
      A = F * B - 0.0000000000019438
      B = F * A - B + 0.0000000000784870
      A = F * B - A - 0.0000000026792535
      B = F * A - B + 0.0000000760816359
      A = F * B - A - 0.0000017619469078
      B = F * A - B + 0.0000324603288210
      A = F * B - A - 0.0004606261662063
      B = F * A - B + 0.0048191800694676
      A = F * B - A - 0.0348937694114089
      B = F * A - B + 0.1580671023320973
      A = F * B - A - 0.3700949938726498
      B = F * A - B + 0.2651786132033368
      A = F * B - A - 0.0087234423528522
      A = F * A - B + 0.3154559429497802
      C331=0.5*(A-B)
      IF(KEY .EQ. 1) RETURN
C
C BERECHNUNG VON Y0
      B = - 0.0000000000000875
      A = F * B + 0.0000000000040263
      B = F * A - B - 0.0000000001583755
      A = F * B - A + 0.0000000052487948
      B = F * A - B - 0.0000001440723327
      A = F * B - A + 0.0000032065325377
      B = F * A - B - 0.0000563207914106
      A = F * B - A + 0.0007531135932578
      B = F * A - B - 0.0072879624795521
      A = F * B - A + 0.0471966895957634
      B = F * A - B - 0.1773020127811436
      A = F * B - A + 0.2615673462550466
      B = F * A - B + 0.1790343140771827
      A = F * B - A - 0.2744743055297453
      A = F * A - B - 0.0662922264065699
      C331=0.636619772367581*LOG(XX)*C331+0.5*(A-B)
      RETURN
C
C BERECHNUNG VON J1
    1 A = - 0.0000000000005777
      B = F * A + 0.0000000000252812
      A = F * B - A - 0.0000000009424213
      B = F * A - B + 0.0000000294970701
      A = F * B - A - 0.0000007617587805
      B = F * A - B + 0.0000158870192399
      A = F * B - A - 0.0002604443893486
      B = F * A - B + 0.0032402701826839
      A = F * B - A - 0.0291755248061542
      B = F * A - B + 0.1777091172397283
      A = F * B - A - 0.6614439341345433
      B = F * A - B + 1.2879940988576776
      A = F * B - A - 1.1918011605412169
      A = F * A - B + 1.2967175412105298
      C331=0.5*(A-B)*Z
      IF(KEY .EQ. 3) RETURN
C
C BERECHNUNG VON Y1
      B = - 0.0000000000000244
      A = F * B + 0.0000000000012114
      B = F * A - B - 0.0000000000517212
      A = F * B - A + 0.0000000018754703
      B = F * A - B - 0.0000000568844004
      A = F * B - A + 0.0000014166243645
      B = F * A - B - 0.0000283046401495
      A = F * B - A + 0.0004404786298671
      B = F * A - B - 0.0051316411610611
      A = F * B - A + 0.0423191803533369
      B = F * A - B - 0.2266249915567549
      A = F * B - A + 0.6756157807721877
      B = F * A - B - 0.7672963628866459
      A = F * B - A - 0.1286973843813500
      A = F * A - B + 0.0406082117718685
      C331=0.636619772367581*(LOG(XX)*C331-1.0/XX)+Z*0.5*(A-B)
      RETURN
C
C ARGUMENT X BETRAGSMAESSIG GROESSER ALS 8.0
    3 Z=8.0/XX
      F=Z+Z
      F=F*F-2.0
      IF(KEY .GT. 2) GOTO 4
C
C VORBEREITENDE BERECHNUNG VON J0 UND Y0
      B = + 0.0000000000000433
      A = F * B - 0.0000000000004305
      B = F * A - B + 0.0000000000051683
      A = F * B - A - 0.0000000000786409
      B = F * A - B + 0.0000000016306465
      A = F * B - A - 0.0000000517059454
      B = F * A - B + 0.0000030751847875
      A = F * B - A - 0.0005365220468132
      A = F * A - B + 1.9989206986950373
      P=A-B
      B = - 0.0000000000000334
      A = F * B + 0.0000000000003006
      B = F * A - B - 0.0000000000032067
      A = F * B - A + 0.0000000000422012
      B = F * A - B - 0.0000000007271916
      A = F * B - A + 0.0000000179724572
      B = F * A - B - 0.0000007414498411
      A = F * B - A + 0.0000683851994261
      A = F * A - B - 0.0311117092106740
      XI=XX-0.7853981633974483
      GOTO 5
C
C VORBEREITENDE BERECHNUNG VON J1 UND Y1
    4 B = - 0.0000000000000468
      A = F * B + 0.0000000000004699
      B = F * A - B - 0.0000000000057049
      A = F * B - A + 0.0000000000881690
      B = F * A - B - 0.0000000018718907
      A = F * B - A + 0.0000000617763396
      B = F * A - B - 0.0000039872843005
      A = F * B - A + 0.0008989898330859
      A = F * A - B + 2.0018060817200274
      P=A-B
      B = + 0.0000000000000360
      A = F * B - 0.0000000000003264
      B = F * A - B + 0.0000000000035152
      A = F * B - A - 0.0000000000468636
      B = F * A - B + 0.0000000008229193
      A = F * B - A - 0.0000000209597814
      B = F * A - B + 0.0000009138615258
      A = F * B - A - 0.0000962772354916
      A = F * A - B + 0.0935555741390707
      XI=XX-2.3561944901923449
    5 Q=(A-B)*Z
      COSXI=COS(XI)
      SINXI=SIN(XI)
      W=0.398942280401433/SQRT(XX)
      IF(AA) GOTO 6
      C331=(P*COSXI-Q*SINXI)*W
      IF(KEY .EQ. 3 .AND. X .LT. 0.0) C331=-C331
      RETURN
    6 C331=(Q*COSXI+P*SINXI)*W
      RETURN
      END
C ../lib/defjm.f
C CALL DEFJM(JM,MODEN,MAZI)
      SUBROUTINE DEFJM(JMA,NNULL,MAZI)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      DOUBLEPRECISION JMA(*)
C
C CALL DEFJM0(JMA,NNULL,MAZI,0)
      CALL SJB931(JMA,NNULL,MAZI,0)
      RETURN
      END
C
      SUBROUTINE DEFJMS(JMA,NNULL,MAZI)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      DOUBLEPRECISION JMA(*)
C
      CALL SJB931(JMA,NNULL,MAZI,1)
      RETURN
      END
C
      SUBROUTINE SJB931(JMA,NNULL,MAZI,KEY)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Naming rule:
C
C (s)ubroutine
C (j) 10.th of
C (b) februar
C '93
C 1.st subroutine
C a b c d e f g h i j k l m n o p q
C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
C
      DOUBLEPRECISION JMA(*)
C
      COMMON /CI2/ M,KEYC
      DOUBLEPRECISION RJB931
      EXTERNAL RJB931
C
C Calculate the relative machine precision
C
      REPS= 1.
      BIN= 0.
    2 CONTINUE
         BIN= BIN+REPS
         REPS= REPS * .5
C write (0,*) reps,bin
         X= BIN + REPS
      IF (X .NE. BIN) GOTO 2
C
C The extended precision arithmetic of the IBM xlf compiler generates
C a reps of 0.
C
      BIN= 1.E-14
      REPS= MAX(4. * REPS, BIN)
C WRITE (0,*) ' sjb931: reps:',REPS
      PI= 4.*ATAN(1.)
      M= MAZI
      KEYC= KEY
      XRI= 1.E-3
      DO 10 N= 1, NNULL, 1
         IERC= 0
   20 CONTINUE
            IERC= IERC + 1
            IF (IERC .GT. 10) THEN
               WRITE (*,*) ' DEFJM0: KEY,IERC:',KEY,IERC
               CALL ErrorStop(' DEFJM0: Can''t find the root..')
            ENDIF
            XLI= XRI
            XRI= XLI + PI
C WRITE (0,*) ' sjb931: xli,xri:',XLI,XRI
            IUNT= 20
            IEND= 40
            CALL C261(X,F,RJB931,XLI,XRI,REPS,IUNT,IEND,IER)
C WRITE (*,*) ' IER,X,F:',IER,X,F
C WRITE (STDERR,*) ' IER,X,F:',IER,X,F
         IF (IER .EQ. 2) GOTO 20
         XRI= X + .25 * PI
C WRITE (STDOUT,*) X
         JMA(N)= X
   10 CONTINUE
      RETURN
      END
C ******************
      DOUBLEPRECISION FUNCTION RJB931(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Naming rule:
C
C (r)eal function
C (j) 10.th of
C (b) februar
C '93
C 1.st function
C a b c d e f g h i j k l m n o p q
C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
C
C
      DIMENSION BESJ(0:100)
      COMMON /CI2/ M,KEY
C
C write (*,*) ' defjm: call c335 x,m+2',x,m+2
      CALL C335(X,M+2,BESJ(0))
      IF (KEY .EQ. 0) THEN
         RJB931= BESJ(M)
      ELSE IF (KEY .EQ. 1) THEN
         RJB931= M * BESJ(M) / X - BESJ(M+1)
      ELSE
         CALL ErrorStop(' rjb931: (KEY .NE. 0) .AND. (KEY .NE. 1)')
      ENDIF
      RETURN
      END
C ../lib/ccopy.f
      SUBROUTINE ZCOPY(N,CX,INCX,CY,INCY)
C
C COPIES A VECTOR, X, TO A VECTOR, Y.
C JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLECOMPLEX CX(*),CY(*)
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        CY(IY) = CX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        CY(I) = CX(I)
   30 CONTINUE
      RETURN
      END
C ../lib/cscal.f
      SUBROUTINE ZSCAL(N,CA,CX,INCX)
C
C SCALES A VECTOR BY A CONSTANT.
C JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLECOMPLEX CA,CX(*)
      INTEGER I,INCX,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        CX(I) = CA*CX(I)
   10 CONTINUE
      RETURN
C
C CODE FOR INCREMENT EQUAL TO 1
C
   20 DO 30 I = 1,N
        CX(I) = CA*CX(I)
   30 CONTINUE
      RETURN
      END
C ../lib/r1mach.f
      DOUBLEPRECISION FUNCTION R1MACH(I)
      INTEGER I
C***BEGIN PROLOGUE R1MACH
C***DATE WRITTEN 790101 (YYMMDD)
C***REVISION DATE 860501 (YYMMDD)
C***CATEGORY NO. R1
C***KEYWORDS MACHINE CONSTANTS
C***AUTHOR FOX, P. A., (BELL LABS)
C HALL, A. D., (BELL LABS)
C SCHRYER, N. L., (BELL LABS)
C***PURPOSE RETURN SINGLE PRECISION MACHINE DEPENDENT CONSTANTS.
C***DESCRIPTION
C
C R1MACH CAN BE USED TO OBTAIN MACHINE-DEPENDENT PARAMETERS
C FOR THE LOCAL MACHINE ENVIRONMENT. IT IS A FUNCTION
C SUBROUTINE WITH ONE (INPUT) ARGUMENT, AND CAN BE CALLED
C AS FOLLOWS, FOR EXAMPLE
C
C A = R1MACH(I)
C
C WHERE I=1,...,5. THE (OUTPUT) VALUE OF A ABOVE IS
C DETERMINED BY THE (INPUT) VALUE OF I. THE RESULTS FOR
C VARIOUS VALUES OF I ARE DISCUSSED BELOW.
C
C SINGLE-PRECISION MACHINE CONSTANTS
C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C R1MACH(5) = LOG10(B)
C***REFERENCES FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR
C A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE-
C MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978,
C PP. 177-188.
C***ROUTINES CALLED XERROR
C***END PROLOGUE R1MACH
C
      DOUBLEPRECISION RDUM,RDUM2,EPS,RMACH
C R1MACH(1) = 1.17549435E-38
C R1MACH(2) = 1.70141163E+38
C R1MACH(3) = 5.960464478E-8
C R1MACH(4) = 1.119209290E-7
C R1MACH(5) = 3.01030010E-1
      IF (I .LT. 1 .OR. I .GT. 5)
     1 CALL XERROR ( 'R1MACH -- I OUT OF BOUNDS',25,1,2)
      RDUM= 1.
    1 CONTINUE
         RDUM= RDUM/2.
         RDUM2= DBLE(1.)+RDUM
         CALL P2(RDUM,RDUM2)
      IF (RDUM2 .NE. DBLE(1.)) GOTO 1
      EPS= RDUM*2.
C eps= 1.e-7
C
      IF (I .EQ. 1) THEN
         IF (EPS .LT. 1.E-7) THEN
            RMACH= DBLE(10.)**(-37.)
         ELSE
            RMACH= DBLE(10.)**(-300.)
         ENDIF
      ELSE IF (I .EQ. 2) THEN
         IF (EPS .LT. 1.E-7) THEN
            RMACH= DBLE(10.)**(+37.)
         ELSE
            RMACH= DBLE(10.)**(+300.)
         ENDIF
      ELSE IF (I .EQ. 3) THEN
         RMACH= EPS*DBLE(8.)
      ELSE IF (I .EQ. 4) THEN
         RMACH= EPS*DBLE(8.)
      ELSE IF (I .EQ. 5) THEN
         RMACH= DLOG10(DBLE(2.))
      ENDIF
C
      R1MACH = RMACH
      RETURN
C
      END
      SUBROUTINE P2(X,Y)
      DOUBLEPRECISION X,Y
      RETURN
      END
C ../lib/lgfWB.f
      DOUBLECOMPLEX FUNCTION CLGFNS(I,Z,CNUE,CMUE)
C23456789012345678901234567890123456789012345678901234567890123456789012
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Calculation of the derivative with respect to cnue
C of the Legendre Function
C
      DOUBLEPRECISION F18393,DFRIDR
      EXTERNAL F18393,DFRIDR
      COMMON /C18393/ CZ,CMU,IDYDX
C
      RDUM= ABS(DIMAG(Z)) + ABS(DIMAG(CNUE)) + ABS(DIMAG(CMUE))
      IF (RDUM .NE. 0.) THEN
         WRITE (*,*) ' clgfn: only implemented for real values..'
         STOP ' clgfn'
      ELSE
         CLGFNS= RLGFNS(I,Z,CNUE,CMUE)
         RETURN
      ENDIF
      CZ= Z
      CMU= CMUE
      IDYDX= I
      X= CNUE
C h= .015*DBLE(cnue)
      RDUM= 1.
      H= .035*DMAX1(DBLE(CNUE),RDUM)
      ERR2= 1.E20
      ERR3= 1.E20
      R1= DFRIDR(F18393,X,H,ERR1)
      IF (ERR1 .GT. 1.E-6) THEN
         HH= H / 2.
         R2= DFRIDR(F18393,X,HH,ERR2)
         IF (ERR2 .LT. ERR1) THEN
            R1= R2
         ELSE
            H2= H*2.
            R3= DFRIDR(F18393,X,H2,ERR3)
            IF (ERR3 .LT. ERR1) R1= R3
         ENDIF
      ENDIF
      ERR= DMIN1(ERR1,ERR2,ERR3)
      IF (ERR .GT. 1.E-4) THEN
         RDUM= F18393(X)
         WRITE (*,*) ' clgfns: err,z,f(z,x),dydx,cnue,cmue,h:',
     1 ERR,DBLE(CZ),RDUM,R1,DBLE(CNUE),DBLE(CMUE),H
      ENDIF
      CLGFNS= R1
      RETURN
      END
C ************
      DOUBLEPRECISION FUNCTION F18393(RNUE)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
      DOUBLECOMPLEX CLGF,CLGFS
      EXTERNAL CLGF,CLGFS
      COMMON /C18393/ CZ,CMU,IDYDX
C
      CNUE= RNUE
      IF (IDYDX .EQ. 0) THEN
         F18393= CLGF (CZ,CNUE,CMU)
      ELSE IF (IDYDX .EQ. 1) THEN
         F18393= CLGFS(CZ,CNUE,CMU)
      ELSE
         WRITE (*,*) ' f18393: idydx .. not yet implemented..',IDYDX
         STOP ' f18393'
      ENDIF
      RETURN
      END
C ************
      DOUBLECOMPLEX FUNCTION CLGFS(Z,CNUE,CMUE)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Calculation of (1-z**2) d/dz P
C
      DOUBLECOMPLEX CLGF
      EXTERNAL CLGF
C
C Bateman 3.8. (19)
C
      CNUEP1= CNUE+1.
      CLGFS= CNUEP1 *Z*CLGF(Z,CNUE ,CMUE)
     1 -(CNUEP1-CMUE)* CLGF(Z,CNUEP1,CMUE)
      RETURN
      END
C **************
      DOUBLECOMPLEX FUNCTION CLGF(Z,CNUE,CMUE)
C23456789012345678901234567890123456789012345678901234567890123456789012
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Switch on your built-in \LaTex-interpreter
C
C Legendre function $ P_\nue(z)^\mue $ for 1-z < 2
C
C Abramowitz/Stegun 8.1.2:
C\[
C P_\nue(z)^\mue =
C \frac 1 \Gamma(1-\mue) \left[\frac z+1 z-1 \right]^ \mue/2
C F\left(-\nue, \nue+1; 1-\mue; \frac 1-z 2 \right)
C\]
C
C
      DOUBLEPRECISION GAMMLN
      DOUBLECOMPLEX HYPGEO,CGAMLN
      EXTERNAL HYPGEO,CGAMLN,GAMMLN
C
      IF (ABS(DIMAG(Z))+ABS(DIMAG(CNUE))+ABS(DIMAG(CNUE)) .EQ. 0.)
     1 THEN
         CLGF= RLGF(Z,CNUE,CMUE)
         RETURN
      ENDIF
      CDUM= 0.
      IF (Z .EQ. CDUM) THEN
C
C Gradstein/Ryshik 8.756.1
C
         PI= 4.*ATAN(DBLE(1.))
         CDUM1= (CNUE-CMUE)/2.+1.
         CDUM2= (-CNUE-CMUE+1.)/2.
         CLGF= 2.**CMUE*SQRT(PI)
     1 /EXP(CGAMLN(CDUM1)+CGAMLN(CDUM2))
         RETURN
      ENDIF
      MUE= INT(DBLE(CMUE))
      CDUM= MUE
      IF (CDUM .EQ. CMUE) THEN
C
C Code for integer cmue
C
         IF (DIMAG(Z) .NE. 0.) THEN
            WRITE (*,10)
   10 FORMAT(' clgf: Integer cmue for complex z'/
     1 '       not implemented.')
            STOP ' clgf'
         ENDIF
         IF (MUE .LT. 0.) THEN
            WRITE (*,20)
   20 FORMAT(' clgf:  negative integer cmue'/
     1 '        not implemented.')
            STOP ' clgf'
         ENDIF
C
C Bateman 3.6.1 (2)
C
         CA= 1.+CMUE+CNUE
         CB= CMUE-CNUE
         CC= 1.+CMUE
         CZ= (1.-Z) / 2.
         CARGG= CNUE+CMUE+1.
         CDUM= CGAMLN(CARGG)
         CARGG= CNUE-CMUE+1.
         RDUM= DBLE(CMUE)+1.
         CDUM= CDUM-CGAMLN(CARGG)-GAMMLN(RDUM)
         CLGF= (-2.)**(-MUE)*EXP(CDUM)*SQRT((1.-DBLE(Z)**2))**MUE
     1 * HYPGEO(CA,CB,CC,CZ)
         RETURN
      ENDIF
C cnull= 0.
C if (cmue .ne. cnull) then
C write (*,*) ' clgf: cmue .ne. 0.'
C stop
C endif
      CA= -CNUE
      CB= CNUE+1
      CC= 1.-CMUE
      CZ= (1.-Z) / 2.
      CARGG= 1.-CMUE
      CLGF= HYPGEO(CA,CB,CC,CZ)
     1 *((Z+1.)/(Z-1.))**(CMUE*.5)/EXP(CGAMLN(CARGG))
      RETURN
      END
C *************************
      DOUBLEPRECISION FUNCTION GAMMLN(XX)
      IMPLICIT CHARACTER*1 (A-Z)
      DOUBLEPRECISION XX
C
C Returns the value $\ln[\Gamma(xx)]$ for $xx > 0$.
C
      INTEGER J
      DOUBLEPRECISION RDUM,PI
      DOUBLE PRECISION SER,STP,TMP,X,Y,COF(6)
      SAVE COF,STP
      DATA COF,STP/76.1 800 917 294 714 6D0,-86.5 053 203 294 167 7D0,
     1 24.0 140 982 408 309 1D0,-1.23 173 957 245 015 5D0,
     2 .120 865 097 386 617 9D-2,
     3 -.539 523 938 495 3 D-5,2.50 662 827 463 100 05D0/
C
      IF (XX .LE. 0.) THEN
         X= 1.-XX
      ELSE
         X= XX
      ENDIF
      Y= X
      TMP= X+5.5D0
      TMP= (X+.5D0)*LOG(TMP)-TMP
      SER= 1.00 000 000 019 001 5D0
      DO 11 J= 1, 6, 1
         Y= Y+1.D0
         SER= SER+COF(J)/Y
   11 CONTINUE
      RDUM= TMP+LOG(STP*SER/X)
      IF (XX .LE. 0) THEN
         PI= 4.*ATAN(DBLE(1.))
C write (*,*) rdum,xx,x
         RDUM= DLOG(PI)-DLOG(SIN(PI*XX))-RDUM
C write (*,*) rdum,pi,sin(pi*xx)
      ENDIF
      GAMMLN= RDUM
      RETURN
      END
C *************
      DOUBLECOMPLEX FUNCTION CGAMLN(XX)
      IMPLICIT CHARACTER*1 (A-Z)
      DOUBLECOMPLEX XX
C
C Returns the value $\ln[\Gamma(xx)]$ for $xx > 0$.
C
      INTEGER J
      DOUBLEPRECISION STP,COF(6),PI
      DOUBLECOMPLEX SER,TMP,X,Y,CDUM
      SAVE COF,STP
      DATA COF,STP/76.1 800 917 294 714 6D0,-86.5 053 203 294 167 7D0,
     1 24.0 140 982 408 309 1D0,-1.23 173 957 245 015 5D0,
     2 .120 865 097 386 617 9D-2,
     3 -.539 523 938 495 3 D-5,2.50 662 827 463 100 05D0/
C
      IF (DBLE(XX) .LE. 0.) THEN
         X= 1.-XX
      ELSE
         X= XX
      ENDIF
      Y= X
      TMP= X+5.5D0
      TMP= (X+.5D0)*LOG(TMP)-TMP
      SER= 1.000000000190015D0
      DO 11 J= 1, 6, 1
         Y= Y+1.D0
         SER= SER+COF(J)/Y
   11 CONTINUE
      CDUM= TMP+ZLOG(STP*SER/X)
      IF (DBLE(XX) .LE. 0) THEN
         PI= 4.*ATAN(DBLE(1.))
C write (*,*) cdum,xx,x
         CDUM= DLOG(PI)-ZLOG(ZSIN(PI*XX))-CDUM
C write (*,*) cdum,pi,ZSIN(pi*xx)
      ENDIF
      CGAMLN= CDUM
      RETURN
      END
C *************
      DOUBLEPRECISION FUNCTION DFRIDR(FUNC,X,H,ERR)
      INTEGER NTAB
      DOUBLEPRECISION ERR,H,X,FUNC,CON,CON2,BIG,SAFE
      PARAMETER (CON=1.4,CON2=CON*CON,BIG=1.E+30,NTAB=15,SAFE=2.)
      EXTERNAL FUNC
C uses func
C
C Returns the derivative of a function func at a point x by Ridder's method
C of polynomial extrapolation. The value h is input as an estimated initial
C stepsize; it need not be small, but rather should be an increment in x over
C which func changes substantially. An estimate of the error in the derivative
C is returned as err.
C Parameters: Stepsize is decreased by CON at each iteration.
C Max size of tableau is set by NTAB.
C Return when error is SAFE worse than the best so far.
C
      INTEGER I,J
      DOUBLEPRECISION ERRT,FAC,HH,A(NTAB,NTAB)
C
      IF (H .EQ. 0) THEN
         WRITE (*,*) ' dfridr: h must be nonzero'
         STOP ' dfridr'
      ENDIF
      HH= H
      A(1,1)= (FUNC(X+HH)-FUNC(X-HH))/(2.*HH)
      ERR= BIG
      DO 12 I= 2, NTAB, 1
C
C Successive columns in the Neville Tableau will go to smaller
C stepsizes and higher orders of extrapolation.
C
C
C Try new, smaller stepsize
C
         HH= HH/CON
         A(1,I)= (FUNC(X+HH)-FUNC(X-HH))/(2.*HH)
         FAC= CON2
         DO 11 J= 2, I, 1
C
C Compute extrapolations of various orders,
C requiring no new function evaluations.
C
            A(J,I)= (A(J-1,I)*FAC-A(J-1,I-1))/(FAC-1.)
            FAC= CON2*FAC
            ERRT= DMAX1(ABS(A(J,I)-A(J-1,I)),ABS(A(J,I)-A(J-1,I-1)))
C
C The error strategy is to compare each new extrapolation to
C one order lower, both at the present stepsize an the
C previous one.
C
            IF (ERRT .LE. ERR) THEN
C
C If error is decreased, save the improved answer.
C
               ERR= ERRT
               DFRIDR= A(J,I)
            ENDIF
   11 CONTINUE
C
C If higher order is worse by a significant factor SAFE,
C then quit early.
C
         IF ((ABS(A(I,I)-A(I-1,I-1)) .GE. SAFE*ERR)
     1 .OR. (ERR .LT. 1.E-7)) THEN
C write (*,*) ' dfridr: evaluations:',2*i
            RETURN
         ENDIF
C
   12 CONTINUE
      RETURN
      END
C *************
      DOUBLECOMPLEX FUNCTION HYPGEO(A,B,C,Z)
      IMPLICIT CHARACTER*1 (A-Z)
      DOUBLECOMPLEX A,B,C,Z
      DOUBLEPRECISION EPS,R1MACH
C
C Accuracy parameter
C
C parameter (eps=1.e-6)
C
C uses bsstep,hypdrv,hypser,odeint
C
C Complex hypergeometric function $ _2F_1$ for DOUBLECOMPLEX
C $a,b,c,$ and $z$, by direct integration of the hypergeometric
C equation in the DOUBLECOMPLEX plane. The branch cut is taken to lie
C along the DOUBLEPRECISION axis, Re $z$ > 1
C
      INTEGER KMAX,NBAD,NOK
      EXTERNAL BSSTEP,HYPDRV
      DOUBLEPRECISION RDUM
      DOUBLECOMPLEX Z0,DZ,AA,BB,CC,Y(2),CDUM
      COMMON /HYPG/ AA,BB,CC,Z0,DZ
      COMMON /PATH/ KMAX
C
C Used by odeint
C
      KMAX= 0
      IF ((DBLE(Z)**2 + DIMAG(Z)**2) .LE. .25) THEN
C
C Use series...
C
C write (*,*) ' hypgeo: Use series...'
         CALL HYPSER(A,B,C,Z,CDUM,Y(2))
         HYPGEO= CDUM
         RETURN
      ELSE IF (DBLE(Z) .LT. 0.) THEN
C
C ...or pick a starting point for the path integration
C
         Z0= -.5
      ELSE IF (DBLE(Z) .LE. 1.) THEN
         Z0= .5
      ELSE
         RDUM= .5
         Z0= (0.,1.)*SIGN(RDUM,DIMAG(Z))
      ENDIF
C
C Load the common block, used to pass parameters
C "over the head" of odeint to hypdrv
C
      AA= A
      BB= B
      CC= C
      DZ= Z-Z0
      EPS= R1MACH(4)*16.
C
C Get starting function and derivative
C
      CALL HYPSER(AA,BB,CC,Z0,Y(1),Y(2))
C
C The arguments to odeint are the vector of independent variables,
C it's length, the starting and ending values of the dependent
C variable, the accuracy parameter, an initial guess for the
C stepsize, a minimum stepsize, the (returned) number of good
C and bad steps taken, and the names of the derivative routine
C and the (here Bulirsch-Stoer) stepping routine.
C
C write (*,*) ' hypgeo: call odeint()...'
      CALL ODEINT(Y,4,DBLE(0.),DBLE(1.),EPS,DBLE(.1),DBLE(1.E-4),
     1 NOK,NBAD,HYPDRV,BSSTEP)
      HYPGEO= Y(1)
      RETURN
      END
C ******************
      SUBROUTINE HYPSER(A,B,C,Z,SERIES,DERIV)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER N
      DOUBLEPRECISION RN,RONE
      PARAMETER (RONE= 1.)
      DOUBLECOMPLEX
     1 A,B,C,Z,SERIES,DERIV,AA,BB,CC,FAC,TEMP
C
C Returns the hypergeometric series $ _2F_1$ and it's derivative,
C iterating to machine accuracy.
C For $ z \le 1/2$ convergence is quite rapid.
C
      DERIV= 0.
      FAC= 1.
      TEMP= FAC
      AA= A
      BB= B
      CC= C
      RN= 0.
      DO 11 N= 1, 1000, 1
         RN= RN+RONE
         FAC= FAC*AA*BB/CC
         DERIV= DERIV+FAC
         FAC= FAC*Z/RN
         SERIES= TEMP+FAC
         IF (SERIES .EQ. TEMP) RETURN
         TEMP= SERIES
         AA= AA+RONE
         BB= BB+RONE
         CC= CC+RONE
   11 CONTINUE
      CALL ErrorStop( ' convergence failure in hypser' )
      RETURN
      END
C ***************
      SUBROUTINE HYPDRV(S,Y,DYDS)
      IMPLICIT CHARACTER*1 (A-Z)
      DOUBLEPRECISION S
      DOUBLECOMPLEX
     1 Y(2),DYDS(2),AA,BB,CC,Z0,DZ,Z
C
C Derivative subroutine for the hypergeometric equation,
C see text equation (5.14.4).
C
      COMMON /HYPG/ AA,BB,CC,Z0,DZ
C
      Z= Z0+S*DZ
      DYDS(1)= Y(2)*DZ
      DYDS(2)= (AA*BB*Y(1)-(CC-(AA+BB+1.)*Z)*Y(2))*DZ/(Z*(1.-Z))
      RETURN
      END
C ****************
      SUBROUTINE ODEINT(YSTART,NVAR,X1,X2,EPS,H1,HMIN,
     1 NOK,NBAD,DERIVS,RKQS)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER NBAD,NOK,NVAR,KMAXX,MAXSTP,NMAX
      DOUBLEPRECISION EPS,H1,HMIN,X1,X2,YSTART(NVAR),TINY
      EXTERNAL DERIVS,RKQS
      PARAMETER (MAXSTP=10 000, NMAX=50, KMAXX=200, TINY=1.E-30)
C
C Runge-Kutta driver with adaptive stepsize control.
C Integrate the starting values ystart(1:nvar)
C from x1 to x2 with accuracy eps, storing intermediate results
C in the common block /path/.
C h1 should be set as a guessed first stepsize, hmin as the minimum
C allowed stepsize (can be zero).
C On output nok and nbad (but retried and fixed) steps taken,
C and ystart is replaced by values at the end of the integration
C interval. derivs is the user supplied subroutine for calculating
C the right-hand side derivative, while rkqs is the name of the
C stepper routine to be used. /path/ contains its own information
C about how often an intermediate value is to be stored.
C
      INTEGER I,KMAX,KOUNT,NSTP
      DOUBLEPRECISION
     1 DXSAV,H,HDID,HNEXT,X,XSAV,DYDX(NMAX),XP(KMAXX),Y(NMAX),
     2 YP(NMAX,KMAXX),YSCAL(NMAX)
C
C User storage for intermediate results. Preset dxsav and kmax
C
      COMMON /PATH/ KMAX,KOUNT,DXSAV,XP,YP
C
      X= X1
      H= SIGN(H1,X2-X1)
      NOK= 0
      NBAD= 0
      KOUNT= 0
      DO 11 I= 1, NVAR, 1
         Y(I)= YSTART(I)
   11 CONTINUE
C
C Assures storage of first step
C
      IF (KMAX .GT. 0) XSAV= X-2.*DXSAV
      DO 16 NSTP= 1, MAXSTP, 1
C
C Take at most MAXSTP steps.
C
         CALL DERIVS(X,Y,DYDX)
         DO 12 I= 1, NVAR, 1
C
C Scaling used to monitor accuracy.
C This general-purpose choice can be modified if need be.
C
            YSCAL(I)= ABS(Y(I))+ABS(H*DYDX(I))+TINY
   12 CONTINUE
         IF (KMAX .GT. 0) THEN
C
C Store intermediate results.
C
            IF (ABS(X-XSAV) .GT. ABS(DXSAV)) THEN
               IF (KOUNT .LT. KMAX-1) THEN
                  KOUNT= KOUNT+1
                  XP(KOUNT)= X
                  DO 13 I= 1, NVAR, 1
                     YP(I,KOUNT)= Y(I)
   13 CONTINUE
                  XSAV= X
               ENDIF
            ENDIF
         ENDIF
C
C If stepsize can overshoot, decrease.
C
         IF ((X+H-X2)*(X+H-X1) .GT. 0.) H= X2-X
         CALL RKQS(Y,DYDX,NVAR,X,H,EPS,YSCAL,HDID,HNEXT,DERIVS)
         IF (HDID .EQ. H) THEN
            NOK= NOK+1
         ELSE
            NBAD= NBAD+1
         ENDIF
C
C Are we done?
C
         IF ((X-X2)*(X2-X1) .GE. 0.) THEN
            DO 14 I= 1, NVAR, 1
               YSTART(I)= Y(I)
   14 CONTINUE
            IF (KMAX .NE. 0) THEN
C
C Save final step.
C
               KOUNT= KOUNT+1
               XP(KOUNT)= X
               DO 15 I= 1, NVAR, 1
                  YP(I,KOUNT)= Y(I)
   15 CONTINUE
            ENDIF
C
C Normal exit
C
            RETURN
         ENDIF
         IF (ABS(HNEXT) .LT. HMIN) THEN
            WRITE (*,*) ' stepsize smaller than minimum in odeint'
            STOP
         ENDIF
         H= HNEXT
   16 CONTINUE
      WRITE (*,*) ' too many steps in odeint'
      STOP
      END
C **************
      SUBROUTINE BSSTEP(Y,DYDX,NV,X,HTRY,EPS,YSCAL,HDID,HNEXT,DERIVS)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER NV,NMAX,KMAXX,IMAX
      DOUBLEPRECISION
     1 EPS,HDID,HNEXT,HTRY,X,DYDX(NV),Y(NV),YSCAL(NV),SAFE1,
     2 SAFE2,REDMAX,REDMIN,TINY,SCALMX
      PARAMETER (NMAX=50,KMAXX=8,IMAX=KMAXX+1,SAFE1=.25,SAFE2=.7,
     1 REDMAX=1.E-5,REDMIN=.7,TINY=1.E-30,SCALMX=.1)
C
C Uses derivs,mmid,pzextr
C
C Bulirsch-Stoer step with monitoring of local truncation error to
C ensure accuracy and adjust stepsize.
C Input are the dependent variable vector y(1:nv) and its derivative
C dydx(1:nv) at the starting value of the independent variable x.
C Also input are the stepsize to be attempted htry, the required
C accuracy eps, and the vector yscal(1:nv) against which the error
C is scaled. On output, y and x are replaced by their new values, hdid is the stepsize that was actually accomplished, and hnext is the
C estimated next stepsize. derivs is the user-supplied subroutine that
C computes the right hand side derivatives. Be sure to set htry on
C successive steps to the next value of hnext returned from the
C previous step, as is the case if the routine is called by odeint.
C Parameters: NMAX is the maximum value of nv; KMAXX is the maximum row
C number used in the extrapolation; IMAX is the next row number;
C SAFE1 and SAFE2 are safety factors; REDMAX is the MAXIMUM factor used
C when a stepsize is reduced, REDMIN the minimum; TINY prevents
C division by zero; 1/SCALMX is the maximaum factor by which a stepsize
C can be increased.
C
      INTEGER I,IQ,K,KK,KM,KMAX,KOPT,NSEQ(IMAX)
      DOUBLEPRECISION
     1 EPS1,EPSOLD,ERRMAX,FACT,H,RED,SCALE,WORK,WRKMIN,XEST,
     2 XNEW,A(IMAX),ALF(KMAXX,KMAXX),ERR(KMAXX),YERR(NMAX),
     3 YSAV(NMAX),YSEQ(NMAX)
      LOGICAL FIRST,REDUCT
      SAVE A,ALF,EPSOLD,FIRST,KMAX,KOPT,NSEQ,XNEW
      EXTERNAL DERIVS
      DATA FIRST/.TRUE./,EPSOLD/-1./
      DATA NSEQ /2,4,6,8,10,12,14,16,18/
C
      IF (EPS .NE. EPSOLD) THEN
C
C A new tolerance, so reinitialize.
C
C "Impossible" Values.
C
         HNEXT= -1.E+29
         XNEW= -1.E+29
         EPS1= SAFE1*EPS
C
C Compute work coefficients A_k
C
         A(1)= NSEQ(1)+1
         DO 11 K= 1, KMAXX, 1
            A(K+1)= A(K)+NSEQ(K+1)
   11 CONTINUE
C
C Compute \alpha(k,q)
C
         DO 13 IQ= 2, KMAXX, 1
            DO 12 K= 1, IQ-1, 1
               ALF(K,IQ)= EPS1**((A(K+1)-A(IQ+1))/
     1 ((A(IQ+1)-A(1)+1.)*(2*K+1)))
   12 CONTINUE
   13 CONTINUE
         EPSOLD= EPS
C
C Determine optimal row number for convergence.
C
         DO 14 KOPT= 2, KMAXX-1, 1
            IF (A(KOPT+1) .GT. A(KOPT)*ALF(KOPT-1,KOPT)) GOTO 1
   14 CONTINUE
    1 CONTINUE
         KMAX= KOPT
      ENDIF
      H= HTRY
C
C Save the starting values.
C
      DO 15 I= 1, NV, 1
         YSAV(I)= Y(I)
   15 CONTINUE
C
      IF ((H .NE. HNEXT) .OR. (X .NE. XNEW)) THEN
C
C A new stepsize or a new integration:
C re-establish the order window.
C
         FIRST= .TRUE.
         KOPT= KMAX
      ENDIF
      REDUCT= .FALSE.
    2 CONTINUE
      DO 17 K= 1, KMAX, 1
C
C Evaluate the sequence of modified midpoint integrations.
C
         XNEW= X+H
         IF (XNEW .EQ. X) THEN
            WRITE (*,*) ' ste size underflow in bsstep'
            STOP
         ENDIF
         CALL MMID(YSAV,DYDX,NV,X,H,NSEQ(K),YSEQ,DERIVS)
C
C Squared, since errors series is even.
C
C
C Perform extrapolation.
C
         CALL PZEXTR(K,XEST,YSEQ,Y,YERR,NV)
C
C Compute normalized error estimate \epsilon(k)
C
         IF (K .NE. 1) THEN
            ERRMAX= TINY
            DO 16 I= 1, NV, 1
               ERRMAX= DMAX1(ERRMAX,ABS(YERR(I)/YSCAL(I)))
   16 CONTINUE
C
C Scale error relative to tolerance.
C
            ERRMAX= ERRMAX/EPS
            KM= K-1
            ERR(KM)= (ERRMAX/SAFE1)**(1./(2*KM+1))
         ENDIF
         IF (K .NE. 1 .AND. K .GE. KOPT-1 .OR. FIRST) THEN
C
C In order window.
C
C
C Converged?
C
            IF (ERRMAX .LT. 1.) GOTO 4
            IF (K .EQ. KMAX .OR. K .EQ. KOPT+1) THEN
C
C Check for possible stepsize reduction.
C
               RED= SAFE2/ERR(KM)
               GOTO 3
            ELSE IF (K .EQ. KOPT) THEN
               IF (ALF(KOPT-1,KOPT) .LT. ERR(KM)) THEN
                  RED= 1./ERR(KM)
                  GOTO 3
               ENDIF
            ELSE IF (KOPT .EQ. KMAX) THEN
               IF (ALF(KM,KMAX-1) .LT. ERR(KM)) THEN
                  RED= ALF(KM,KMAX-1)*
     1 SAFE2/ERR(KM)
                  GOTO 3
               ENDIF
            ELSE IF (ALF(KM,KOPT) .LT. ERR(KM)) THEN
               RED= ALF(KM,KOPT-1)/ERR(KM)
               GOTO 3
            ENDIF
         ENDIF
   17 CONTINUE
    3 CONTINUE
C
C Reduce stepsize by at least REDMIN and at most REDMAX.
C
      RED= DMIN1(RED,REDMIN)
      RED= DMAX1(RED,REDMAX)
      H= H*RED
      REDUCT= .TRUE.
C
C Try again
C
      GOTO 2
C
C Successfull step taken
C
    4 CONTINUE
      X= XNEW
      HDID= H
      FIRST= .FALSE.
      WRKMIN= 1.E+35
C
C Compute optimal row for convergence and corresponding stepsize
C
      DO 18 KK= 1, KM, 1
         FACT= DMAX1(ERR(KK),SCALMX)
         WORK= FACT*A(KK+1)
         IF (WORK .LT. WRKMIN) THEN
            SCALE= FACT
            WRKMIN= WORK
            KOPT= KK+1
         ENDIF
   18 CONTINUE
      HNEXT= H/SCALE
      IF (KOPT .GE. K .AND. KOPT .NE. KMAX .AND. .NOT. REDUCT) THEN
C
C Check for possible order increase,
C but not if stepsize was just reduced.
C
         FACT= DMAX1(SCALE/ALF(KOPT-1,KOPT),SCALMX)
         IF (A(KOPT+1)*FACT .LE. WRKMIN) THEN
            HNEXT= H/FACT
            KOPT= KOPT+1
         ENDIF
      ENDIF
      RETURN
      END
C *********
      SUBROUTINE PZEXTR(IEST,XEST,YEST,YZ,DY,NV)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER IEST,NV,IMAX,NMAX
      DOUBLEPRECISION
     1 XEST,DY(NV),YEST(NV),YZ(NV)
      PARAMETER (IMAX=13, NMAX= 50)
C
C Use polynomial extrapolation to evaluate nv functions at x=0
C by fitting a polynomila to a sequence of estimates with
C progressively smaller values x=xest, and corresponding function
C vectors yest(1:nv). This call is number iest in the sequence of
C calls. Extrapolated function values are output as yz(1:nv), and their
C estimated error is output as dy(1:nv).
C Parameters: Maximum expected value of iest is IMAX; of nv is NMAX.
C
      INTEGER J,K1
      DOUBLEPRECISION
     1 DELTA,F1,F2,Q,D(NMAX),QCOL(NMAX,IMAX),X(IMAX)
      SAVE QCOL,X
C
C Save current independent variable.
C
      X(IEST)= XEST
      DO 11 J= 1, NV, 1
         DY(J)= YEST(J)
         YZ(J)= YEST(J)
   11 CONTINUE
      IF (IEST .EQ. 1) THEN
C
C Store first estimate in first column.
C
         DO 12 J= 1, NV, 1
            QCOL(J,1)= YEST(J)
   12 CONTINUE
      ELSE
         DO 13 J= 1, NV, 1
            D(J)= YEST(J)
   13 CONTINUE
         DO 15 K1= 1, IEST-1, 1
            DELTA= 1./(X(IEST-K1)-XEST)
            F1= XEST*DELTA
            F2= X(IEST-K1)*DELTA
            DO 14 J= 1, NV, 1
C
C Propagate tableau 1 diagonal more.
C
               Q= QCOL(J,K1)
               QCOL(J,K1)= DY(J)
               DELTA= D(J)-Q
               DY(J)= F1*DELTA
               D(J)= F2*DELTA
               YZ(J)= YZ(J)+DY(J)
   14 CONTINUE
   15 CONTINUE
         DO 16 J= 1, NV, 1
            QCOL(J,IEST)= DY(J)
   16 CONTINUE
      ENDIF
      RETURN
      END
C ************
      SUBROUTINE MMID(Y,DYDX,NVAR,XS,HTOT,NSTEP,YOUT,DERIVS)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER NSTEP,NVAR,NMAX
      DOUBLEPRECISION
     1 HTOT,XS,DYDX(NVAR),Y(NVAR),YOUT(NVAR)
      EXTERNAL DERIVS
      PARAMETER (NMAX=50)
C
C Modified midpoint step.
C Dependent Variable vector y(1:nvar) and its derivative vector
C dydx(1:nvar) are input at xs. Also input is htot, the total step to
C be made, and nstep, the number of steps to be used. The output is
C returned as yout(1:nvar), which need not be a distinct array from y;
C if it is distinct, however, then y and dydx are returned undamaged.
C
      INTEGER I,N
      DOUBLEPRECISION
     1 H,H2,SWAP,X,YM(NMAX),YN(NMAX)
C
C Stepsize this trip
C
      H= HTOT/NSTEP
      DO 11 I= 1, NVAR, 1
         YM(I)= Y(I)
C
C First step.
C
         YN(I)= Y(I)+H*DYDX(I)
   11 CONTINUE
      X= XS+H
C
C Will use yout for temporary storage.
C
      CALL DERIVS(X,YN,YOUT)
      H2= H+H
      DO 13 N= 2, NSTEP, 1
         DO 12 I= 1, NVAR, 1
            SWAP= YM(I)+H2*YOUT(I)
            YM(I)= YN(I)
            YN(I)= SWAP
   12 CONTINUE
         X= X+H
         CALL DERIVS(X,YN,YOUT)
   13 CONTINUE
C
C Last step.
C
      DO 14 I= 1, NVAR, 1
         YOUT(I)= .5*(YM(I)+YN(I)+H*YOUT(I))
   14 CONTINUE
      RETURN
      END
C ../lib/rlgf.f
      DOUBLEPRECISION FUNCTION RLGFNS(I,RX,RNUE,RMUE)
C23456789012345678901234567890123456789012345678901234567890123456789012
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Calculation of the derivative with respect to rnue
C of the Legendre Function
C
      DOUBLEPRECISION F23393,DFRIDR
      EXTERNAL F23393,DFRIDR
      COMMON /C23393/ RZ,RMU,IDYDX
      COMMON /CI1/ IERR
C
      IERR= 0
      RZ= RX
      RMU= RMUE
      IDYDX= I
      X= RNUE
C h= .015*rnue
      RDUM= 1.
      H= DMAX1(RDUM, DMIN1(RNUE*.5+1.E-2, 8.E-4*RNUE/RX))
C write (*,*) ' rlgfns: h',h
      ERR2= 1.E20
      ERR3= 1.E20
      R1= DFRIDR(F23393,X,H,ERR1)
      IF (ERR1 .GT. 1.E-6) THEN
         HH= H / 2.
         R2= DFRIDR(F23393,X,HH,ERR2)
         IF (ERR2 .LT. ERR1) THEN
C write (*,*) ' halbe Schrittweite ..'
            R1= R2
         ELSE
            H2= H*2.
            R3= DFRIDR(F23393,X,H2,ERR3)
            IF (ERR3 .LT. ERR1) R1= R3
C if (err3 .lt. err1) write (*,*) ' doppelte Schrittweite'
         ENDIF
      ENDIF
      ERR= DMIN1(ERR1,ERR2,ERR3)
      IF (ERR .GT. 1.E-4) THEN
         RDUM= F23393(X)
         WRITE (0,*) ' rlgfns: err,rx,f(rx,x),dydx,rnue,rmue,h:',
     1 ERR,RX,RDUM,R1,RNUE,RMUE,H
         IERR= 1
      ENDIF
      RLGFNS= R1
      RETURN
      END
C ************
      DOUBLEPRECISION FUNCTION F23393(RNUE)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Real (F)unction, 23. 3. '93
C
      DOUBLEPRECISION RLGF,RLGFS
      EXTERNAL RLGF,RLGFS
      COMMON /C23393/ RX,RMU,IDYDX
C
      IF (IDYDX .EQ. 0) THEN
         F23393= RLGF (RX,RNUE,RMU)
      ELSE IF (IDYDX .EQ. 1) THEN
         F23393= RLGFS(RX,RNUE,RMU)
      ELSE
         WRITE (0,*) ' f23393: idydx .. not yet implemented..',IDYDX
         STOP ' f23393'
      ENDIF
      RETURN
      END
C ************
      DOUBLEPRECISION FUNCTION RLGFS(THETA,RNUE,RMUE)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Calculation of - sin(theta) d/dtheta P(cos(theta))
C
      DOUBLEPRECISION RLGF
      EXTERNAL RLGF
C
C Bateman 3.8. (19)
C oder A/S 8.5.4, 8.5.3
C
      RNUEP1= RNUE+1.
      RLGFS= RNUEP1 *COS(THETA)*RLGF(THETA,RNUE ,RMUE)
     1 -(RNUEP1-RMUE)* RLGF(THETA,RNUEP1,RMUE)
      RETURN
      END
C **************
      DOUBLEPRECISION FUNCTION RLGF(THETA,RNUE,RMUE)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C See 'plgndr' in Numerical Recipes
C
C****
C IF (RNUE .GT. -1.E6) THEN
C rlgf= RLGFA(THETA,RNUE,RMUE)
C CV= RNUE
C CZ= COS(THETA)
C NF= 1
C CALL LEGFN(CV,CZ,CP,CQ,NC,NF)
C RLGF= CP
C RETURN
C ENDIF
C****
      N= INT(RNUE)
      M= INT(RMUE)
      RNI= RNUE-DBLE(N)+RMUE
      PMM= RLGFA(THETA,RNI,RMUE)
      IF (ABS(RNI-RNUE) .LE. 1.E-6) THEN
         RLGF= PMM
         RETURN
      ENDIF
C
      RNI= RNI+1.
      PMMP1= RLGFA(THETA,RNI,RMUE)
      IF (ABS(RNI-RNUE) .LE. 1.E-6) THEN
         RLGF= PMMP1
         RETURN
      ENDIF
      X= COS(THETA)
      RLL= RNI+1.
C
      IF (N .LT. M+2) THEN
         WRITE (0,*) ' pmm,pmmp1',PMM,PMMP1
         WRITE (0,*) ' rlgfa(theta,rnue,rmue)',RLGFA(THETA,RNUE,RMUE)
         WRITE (0,*) ' rlgf: n .lt. m+2',N,M+2,RNUE,RMUE,THETA
C STOP
         RLGF= RLGFA(THETA,RNUE,RMUE)
         RETURN
      ENDIF
C
      DO 12 LL= M+2, N, 1
         PLL= (X*(2.*RLL-1.)*PMMP1-(RLL+RMUE-1.)*PMM)/(RLL-RMUE)
         PMM= PMMP1
         PMMP1= PLL
         RLL= RLL+1.
   12 CONTINUE
      RLGF= PLL
      RETURN
      END
C **************
      DOUBLEPRECISION FUNCTION RLGFA(THETA,RNUE,RMUE)
C23456789012345678901234567890123456789012345678901234567890123456789012
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Switch on your built-in \LaTex-interpreter
C
C Legendre function $ P_\nue(cos(theta))^\mue $
C
C Abramowitz/Stegun 8.1.2:
C\[
C P_\nue(z)^\mue =
C \frac 1 \Gamma(1-\mue) \left[\frac z+1 z-1 \right]^ \mue/2
C F\left(-\nue, \nue+1; 1-\mue; \frac 1-z 2 \right)
C\]
C
C
      DOUBLEPRECISION GAMMLN
      DOUBLECOMPLEX HYPGEO,CGAMLN
      EXTERNAL HYPGEO,CGAMLN,GAMMLN
C
      RCTH= COS(THETA)
      M= INT(RMUE)
      N= INT(RNUE)
      IF (.TRUE.) THEN
      IF ((ABS(DBLE(M)-RMUE) .LE. 1.E-6) .AND.
     1 (ABS(DBLE(N)-RNUE) .LE. 1.E-6)) THEN
C write (*,*) ' Polynom'
C
C Calculation as a polynom
C
         IF (M .GT. N) THEN
            WRITE (*,*) ' rlgfa: rmue .gt. rnue',RMUE, RNUE
            RLGFA= 0.
            RETURN
         ENDIF
         X= RCTH
         PMM= 1.
         IF (M .GT. 0) THEN
            SOMX2= SQRT((1.-X)*(1.+X))
            FACT= 1.
            DO 11 I= 1, M, 1
               PMM= -PMM*FACT*SOMX2
               FACT= FACT+2.
   11 CONTINUE
         ENDIF
         IF (N .EQ. M) THEN
            RLGFA= PMM
         ELSE
            PMMP1= X*(2*M+1)*PMM
            IF (N .EQ. (M+1)) THEN
               RLGFA= PMMP1
            ELSE
               DO 12 LL= M+2, N, 1
                  PLL= (X*(2*LL-1)*PMMP1-(LL+M-1)*PMM)/(LL-M)
                  PMM= PMMP1
                  PMMP1= PLL
   12 CONTINUE
               RLGFA= PLL
            ENDIF
         ENDIF
         RETURN
      ENDIF
      ENDIF
C
      IF (ABS(RCTH) .LE. 1.E-6) THEN
C
C Gradstein/Ryshik 8.756.1
C
         CDUM1= (RNUE-RMUE)/2.+1.
         CDUM2= (-RNUE-RMUE+1.)/2.
         RLGFA= 2.**RMUE*SQRT(4.*ATAN(DBLE(1.)))
     1 /EXP(CGAMLN(CDUM1)+CGAMLN(CDUM2))
         RETURN
      ENDIF
      MUE= INT(RMUE)
      RDUM= MUE
C IF (RDUM .EQ. RMUE) THEN
      IF (ABS(RDUM-RMUE) .LT. 1.E-6) THEN
C
C Code for integer rmue
C
         IF (MUE .LT. 0) THEN
            WRITE (0,20)
   20 FORMAT(' rlgfa:  negative integer rmue'/
     1 '        not implemented.')
            STOP ' rlgfa'
         ENDIF
C IF (RNUE .EQ. 0.) THEN
         IF (ABS(RNUE) .LE. 1.E-6) THEN
            IF (MUE .EQ. 0) THEN
               RLGFA= 1.
            ELSE
               RLGFA= 0.
            ENDIF
            RETURN
         ENDIF
         RDUM= 10.
C RDUM= 1.E+32
         IF (ABS(DMAX1(ABS(RNUE),RDUM)*THETA) .LT. .5) THEN
C IF (.TRUE.) THEN
C
C Bateman 3.4. (17), 3.5. (10)
C oder Gradshteyn/Ryzhik 8.722.1, 8.736.1
C
C WRITE(0,*) ' Naeherung Bateman 3.4. (17),  3.5. (10) ..'
            THETAH= THETA/2.
            A= (2.*RNUE+1.)*SIN(THETAH)
            CA= A
            RJM3= ZJM(MUE+3,CA)
            RJM2= ZJM(MUE+2,CA)
            RJM1= ZJM(MUE+1,CA)
            RDUM= ((RNUE+.5)*COS(THETAH))**(-MUE)
     1 *(DBLE(ZJM(MUE,CA))
     2 + SIN(THETAH)**2 * (A*RJM3/6.-RJM2+RJM1/(2.*A))
     3 )
            RDUM1= RNUE+RMUE+1.
            RDUM2= RNUE-RMUE+1.
            RLGFA= RDUM*EXP(GAMMLN(RDUM1)-GAMMLN(RDUM2))
     1 *(-1)**MUE
C rlgfa= 1.
C
C else if ((rnue .gt. 200.)
C 1 .and. (theta .gt. .1 )) then
          ELSE IF ((THETA .GT. 0.07*400/RNUE) .AND. (RMUE .GT. 0.)) THEN
C else if (sqrt(abs(sin(theta)/rnue**2)) .lt. 1.e-4) then
C
C Gradshteyn/Ryzhik 8.721.4
C
      WRITE (0,*) ' Naeherung Gradshteyn/Ryzhik 8.721.4'
            PI= 1.
            PI= 4.*ATAN(PI)
            RLGFA= RNUE**MUE * SQRT(2./(RNUE*PI*SIN(THETA)))
     1 *COS((RNUE+.5)*THETA-PI/4.+RMUE*PI/2.)
C rlgfa= 2.
         ELSE
C
C Bateman 3.6.1 (2)
C
C write (0,*) ' Bateman 3.6.1 (2)',rmue,rnue,theta
            CA= 1.+RMUE+RNUE
            CB= RMUE-RNUE
            CC= 1.+RMUE
            CZ= (1.-COS(THETA)) / 2.
C write (*,*) theta,cos(theta)
            RARGG= RNUE+RMUE+1.
            RDUM= GAMMLN(RARGG)
            RARGG= RNUE-RMUE+1.
            RDUM2= RMUE+1.
            RDUM= RDUM-GAMMLN(RARGG)-GAMMLN(RDUM2)
            RLGFA= (-2.)**(-MUE)*EXP(RDUM)*SIN(THETA)**MUE
     1 * HYPGEO(CA,CB,CC,CZ)
         ENDIF
      ELSE
C
C Bateman 3.4 (6)
C Abramowitz/ Stegun 8.1.2
C
      WRITE (0,*) ' Bateman 3.4 (6)'
         CA= -RNUE
         CB= RNUE+1
         CC= 1.-RMUE
         X= COS(THETA)
         CZ= (1.-X) / 2.
         RARGG= 1.-RMUE
         RLGFA= HYPGEO(CA,CB,CC,CZ)
     1 *((X+1.)/(X-1.))**(RMUE/2.)*EXP(-GAMMLN(RARGG))
      ENDIF
      RETURN
      END
C ../kazi/defnu.f
      SUBROUTINE DEFNU(IDYDX,THETA,CNUE,RJM,NNULL,MAZI)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      DOUBLECOMPLEX CNUE(*)
      DOUBLEPRECISION RJM(*)
C
C
      COMMON /CI2R1/ M,KEYC,ARG
      DOUBLEPRECISION RTC931
      EXTERNAL RTC931
C
      IF (ABS(1.+COS(THETA)) .LE. 1.E-6) THEN
         DO 1 I= 1, NNULL, 1
            CNUE(I)= MAZI+I-1
    1 CONTINUE
         RETURN
      ENDIF
C
C Calculate the relative machine precision
C
      REPS= 1.
    2 CONTINUE
         REPS= REPS * .5
         X= 1. + REPS
      IF (X .NE. 1.) GOTO 2
C
C The extended Precision of the IBM xlf compiler generates
C a reps of 0.
C
      RMIN= 1.E-14
      REPS= MAX(4. * REPS, RMIN)
      PI= 4.*ATAN(1.)
      M= MAZI
      RMUE= DBLE(MAZI)
      ARG= THETA
      KEYC= IDYDX
      STHETH= SIN(THETA/2.)
C if (stheth .lt. 1.e-2) then
         RDUM= 1.E-3
         XRI= DMAX1(
     1 RJM(1)*(1.-STHETH**2*(1.-(4.*RMUE**2-1.)/RJM(1)**2)/6.)
     2 /(2.*STHETH) - .9,
     3 RDUM)
C else
C XRI= 1.E-3 + DBLE(idydx) + rmue*idydx/max0(idydx,1)
C endif
C XRI= 1.E-3
      DO 10 N= 1, NNULL, 1
         IERC= 0
   20 CONTINUE
            IERC= IERC + 1
            IF (IERC .GT. 100) THEN
               WRITE (0,*) ' DEFNU: KEY,IERC:',KEY,IERC
               CALL ErrorStop(' DEFNU: Can''t find the root..')
            ENDIF
            XLI= XRI
            RDUM= 1./100.
            XRI= XLI + 2./DMAX1(RDUM,ABS(SIN(THETA)))
            IUNT= 40
            IEND= 80
            CALL C261(X,F,RTC931,XLI,XRI,REPS,IUNT,IEND,IER)
       WRITE (0,*) ' IER,X,F,arg:',IER,X,F,ARG*45./DATAN(1.D0)
C WRITE (STDERR,*) ' IER,X,F:',IER,X,F
         IF (IER .EQ. 2) GOTO 20
C XRI= X + .25
         XRI= X + 1.E-3
C WRITE (STDOUT,*) X
      RDUM= RJM(N)*(1.-STHETH**2*(1.-(4.*RMUE**2-1.)/RJM(N)**2)/6.)
     1 /(2.*STHETH) - .5
      WRITE (0,*) ' 8.787:',RDUM,RDUM/X
         CNUE(N)= X
   10 CONTINUE
      WRITE (0,*) ' Ende von defnu..'
      RETURN
      END
C ******************
      DOUBLEPRECISION FUNCTION RTC931(X)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Naming rule:
C
C (r)eal function
C (t) 20.th of
C (c) march
C '93
C 1.st function
C a b c d e f g h i j k l m n o p q r s t
C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
C
C
      COMMON /CI2R1/ M,KEY,ARG
C
      RZ= ARG
      RNUE= X
      RMUE= DBLE(M)
      IF (KEY .EQ. 0) THEN
         RTC931= RLGF (RZ,RNUE,RMUE)
      ELSE IF (KEY .EQ. 1) THEN
         RTC931= RLGFS(RZ,RNUE,RMUE)
      ELSE
         CALL ErrorStop(' rtc931: (KEY .NE. 0) .AND. (KEY .NE. 1)')
      ENDIF
      RETURN
      END
C ../kazi/chan.f
C23456789012345678901234567890123456789012345678901234567890123456789012
      INTEGER FUNCTION I30393(M)
C IF (M .EQ. 1) THEN
C I= 2
C ELSEIF (M .EQ. 2) THEN
C I= 1
C ELSE
C STOP ' i30393'
C ENDIF
      I= M
      I30393= I
      RETURN
      END
C ******
      DOUBLECOMPLEX FUNCTION CRR (NO,MO,FNUE,X,XB,XR)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      CRR= CGD931(1,NO,MO,FNUE,X,XB,XR)
      RETURN
      END
C ******
      DOUBLECOMPLEX FUNCTION CRRS(NO,MO,FNUE,X,XB,XR)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      CRRS= CGD931(2,NO,MO,FNUE,X,XB,XR)
      RETURN
      END
C ********
      DOUBLECOMPLEX FUNCTION CRRSR(NO,MO,FNUE,X,XB,XR)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Berechnung von \frac 1 r \frac d dr (rR(kr))
C
      CRRSR= CGD931(3,NO,MO,FNUE,X,XB,XR)
      RETURN
      END
C ******
      DOUBLECOMPLEX FUNCTION CGD931(KEY,NO,MO,RNUE,X,XBO,XR)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C
C Naming rule:
C
C (c)omplex function
C (g) 07.th of
C (d) april
C '93
C 1.st subroutine
C a b c d e f g h i j k l m n o p q
C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
C
      PARAMETER (RNULL= 0.)
      DIMENSION CY(2)
      COMMON /CIGN/ IGN
      COMMON /CISRC/ ISRC
      COMMON /STDIO/ ITDIN,ITDOUT,ITDERR
C
      FNUE= RNUE+.5
C IF (XBO .GT. FNUE) THEN
         NA= NO
C ELSE
C IF (NO .EQ. IGN) THEN
C NA= NO
C ELSE
C NA= -1
C ENDIF
C ENDIF
      M= I30393(MO)
C *****
C IF ((NO .EQ. 0) .AND. (ISRC .EQ. 0)) THEN
         IF (M .EQ. 2) ISRC= -1
C ELSE
C ISRC= -1
C NA= -1
C ENDIF
C *****
C WRITE (0,*) ' CGD931',X ,FNUE,KEY,NO,MO
      CALL BESSJY(X ,FNUE,RJ ,RY ,RJP ,RYP )
C WRITE (0,*) ' CGD931',XBo,FNUE,KEY,NO,MO
      XB= XBO
      CALL BESSJY(XB,FNUE,RJB,RYB,RJPB,RYPB)
C
C IF (XB .GT. FNUE) THEN
      RDUM= ABS(RJB)+ABS(RYB)
      IF (RDUM .LE. 1.E+4) THEN
         RDUM= 1./RDUM
C
C Both Hankel Functions are in the order of 1
C
         IF ((ISRC .EQ. 0) .OR. (NA .EQ. IGN)) THEN
C
C Hankelfunction of the excitation
C
            IF (M .EQ. 1) THEN
               CY(1)= DCMPLX(RJ *RDUM, RY *RDUM)
               CY(2)= DCMPLX(RJP*RDUM, RYP*RDUM)
            ELSE
               CY(1)= DCMPLX(RJ *RDUM,-RY *RDUM)
               CY(2)= DCMPLX(RJP*RDUM,-RYP*RDUM)
            ENDIF
         ELSE
            IF (M .EQ. 2) THEN
               CY(1)= RJ *RDUM
               CY(2)= RJP*RDUM
            ELSE IF (M .EQ. 1) THEN
               CY(1)= DCMPLX(RNULL, RY *RDUM)
               CY(2)= DCMPLX(RNULL, RYP*RDUM)
            ENDIF
         ENDIF
      ELSE
C
C Order .ge. Argument
C
C IF (.TRUE.) THEN
C WRITE (0,*) ' CGD931: Order .ge. Argument',XB,FNUE
C STOP
C ENDIF
         RDUM= FNUE*LOG10(2.718281828*XB/(2.*FNUE))
         IF (RDUM .LT. -260.) GOTO 9
         IF (ABS(RYB) .GT. 1.D+260) GOTO 10
C
C NaN?
C
         IF (RYB .NE. RYB) GOTO 10
         IF ((ISRC .EQ. 0) .OR. (NA .EQ. IGN)) THEN
            RDUM= 1./RYB
            CY(1)= DCMPLX(RJ ,RY *(-1)**(M+1)) * RDUM
            CY(2)= DCMPLX(RJP,RYP*(-1)**(M+1)) * RDUM
         ELSE
            IF (M .EQ. 2) THEN
               CY(1)= RJ / RJB
               CY(2)= RJP / RJB
            ELSE IF (M .EQ. 1) THEN
               CY(1)= DCMPLX(RNULL, RY / RYB)
               CY(2)= DCMPLX(RNULL, RYP / RYB)
            ENDIF
         ENDIF
         GOTO 900
    9 CONTINUE
C IF (.FALSE. ) THEN
C WRITE (*,*) ' rdum:',RDUM
C WRITE (ITDERR,*) ' rdum:',RDUM
C ENDIF
   10 CONTINUE
C write ( *,*) ' fnue*log10(2.718281828*xb/(2.*fnue)):',
C 1 fnue*log10(2.718281828*xb/(2.*fnue))
C write (itderr,*) ' fnue*log10(2.718281828*xb/(2.*fnue)):',
C 2 fnue*log10(2.718281828*xb/(2.*fnue))
         RDUMJ= (X/XB)**FNUE
         RDUMY = 1./RDUMJ
         RDUMJP= FNUE * (X/XB)**( FNUE-1.) / XB
         RDUMYP= -FNUE * (X/XB)**(-FNUE-1.) / XB
C
      IF (.FALSE.) THEN
      WRITE (0,*) ' CRRS:        fnue,x,xb:',FNUE,X,XB
      WRITE (0,*) ' CRRS: exakt, Naeherung:',RJP,RJP/RJB,RDUMJP
     1 ,RJP/RJB/RDUMJP
      WRITE (0,*) '                        ',RYP,RYP/RYB,RDUMYP
     1 ,RYP/RYB/RDUMYP
      WRITE (0,*) '                        ',RJ ,RJ /RJB,RDUMJ
     1 ,RJ /RJB/RDUMJ
      WRITE (0,*) '                        ',RY ,RY /RYB,RDUMY
     1 ,RY /RYB/RDUMY
      WRITE (ITDERR,*) ' CRRS:        fnue,x,xb:',FNUE,X,XB
      WRITE (ITDERR,*) ' CRRS: exakt, Naeherung:',RJP,RJP/RJB,RDUMJP
     1 ,RJP/RJB/RDUMJP
      WRITE (ITDERR,*) '                        ',RYP,RYP/RYB,RDUMYP
     1 ,RYP/RYB/RDUMYP
      WRITE (ITDERR,*) '                        ',RJ ,RJ /RJB,RDUMJ
     1 ,RJ /RJB/RDUMJ
      WRITE (ITDERR,*) '                        ',RY ,RY /RYB,RDUMY
     1 ,RY /RYB/RDUMY
      ENDIF
C E= EXP(1.D0)
C PI= 4.D0*DATAN(1.D0)
C RDUM1= (E*X/(2.*FNUE))** FNUE / SQRT(2.* PI*FNUE )
C RDUM2= -(E*X/(2.*FNUE))**(-FNUE) * SQRT(2./(PI*FNUE))
C
         RDUM= FNUE*2./2.718281828
         IF (X .GT. RDUM) STOP
         IF (XB .GT. RDUM) STOP
         IF ((ISRC .EQ. 0) .OR. (NA .EQ. IGN)) THEN
            CY(1)= (0.,1.) * (-1)**(M+1) * RDUMY
            CY(2)= (0.,1.) * (-1)**(M+1) * RDUMYP
         ELSE
            IF (M .EQ. 2) THEN
               CY(1)= RDUMJ
               CY(2)= RDUMJP
            ELSE IF (M .EQ. 1) THEN
               CY(1)= DCMPLX(RNULL, RDUMY )
               CY(2)= DCMPLX(RNULL, RDUMYP)
            ENDIF
         ENDIF
  900 CONTINUE
      ENDIF
C
C
C
 9900 CONTINUE
C
C *****
C
      XB= 1.
C
C *****
C
      IF (KEY .EQ. 1) THEN
         CDUM= CY(1) * SQRT(XB/X)
      ELSE IF (KEY .EQ. 2) THEN
         WRITE (0,*) ' CGD931: key .eq. 2 not implemented'
         STOP
C CDUM= ( -.5/X * CY(1) + CY(2) ) / SQRT(X)
      ELSE IF (KEY .EQ. 3) THEN
C* CDUM= ( CY(1)
C* 1 + X * ( -.5/X * CY(1) + CY(2) ) / SQRT(X)
C* 2 ) / XR
C
         CDUMP= -0.5*(X/XB)**(-3./2.) * CY(1)
     1 + (X/XB)**(-1./2.) * CY(2)
         CDUM= (CY(1) * SQRT(XB/X)
     1 + X * CDUMP
     2 ) / XR
      ELSE
         WRITE (0,*) ' CGD931: key:',KEY
         CALL ErrorStop(' Key darf 1,2 oder 3 sein ...')
      ENDIF
C write (*,*) key,cdum
C write (itderr,*) key,cdum
      CGD931= CDUM
      RETURN
      END
C ../kazi/chebev.f
C2345678
      DOUBLEPRECISION FUNCTION CHEBEV(A,B,C,M,X)
      INTEGER M
      DOUBLEPRECISION A,B,X,C(M)
C
C Chebyshev evaluation: All argumenst are input. c(1:m) is an array of
C Chebyshev coefficients, the first m elements of c output from
C chebft (which must have been called with the same a and b).
C The Chebyshev polynomila \sum_ k=1 ^m c_kT_ k-1 (y) - c_1/2
C is evaluated at a point y= [x-(b-a)/2]/[(b-a)/2], and the result
C is returned as the funcion value.
C
      INTEGER J
      DOUBLEPRECISION D,DD,SV,Y,Y2
C
      IF ((X-A)*(X-B) .GT. 0.) THEN
         CALL ErrorStop(' x not in range in CHEBEV')
      END IF
      D= 0.
      DD= 0.
C
C Change of variable.
C
      Y= (2.*X-A-B)/(B-A)
      Y2= 2.*Y
      DO 11 J= M, 2, -1
C
C Clenshaw's recurrence.
C
         SV= D
         D= Y2*D-DD+C(J)
         DD= SV
   11 CONTINUE
C
C Last step is different.
C
      CHEBEV= Y*D-DD+.5*C(1)
      RETURN
      END
C ../kazi/bessjy.f
C2345678
      SUBROUTINE BESSJY(X,XNU,RJ,RY,RJP,RYP)
      IMPLICIT CHARACTER*1 (A-Z)
      INTEGER MAXIT
      DOUBLEPRECISION RJ,RJP,RY,RYP,X,XNU,XMIN
      DOUBLE PRECISION EPS,FPMIN,PI
      PARAMETER (EPS=1.D-14,FPMIN=1.D-300,MAXIT=10 000,XMIN= 2.)
C
C Returns the Bessel functions rj=J_\nu, ry=Y_\nu and their
C derivatives rjp= J_\nu^ ' , ryp= Y_\nu^ ' ,
C for positive x and for xnu= \nu \ge 0.
C The relative accuracy is within one or two significant
C digits of EPS, except near a zero of one of the functions,
C where EPS controls its absolute accuracy.
C FPMIN is a number close to the machine's smallest floating point
C number. All internal arithmetic is in double precision.
C To convert the entire routine to double precision, change the DOUBLEPRECISION
C declaration above and decrease EPS to 1.e-16. Also convert the
C subroutine beschb.
C
      INTEGER I,ISIGN,L,NL
      DOUBLE PRECISION A,B,BR,BI,C,CR,CI,D,DEL,DEL1,DEN,DI,DLR,DLI,
     1 DR,E,F,FACT,FACT2,FACT3,FF,GAM,GAM1,GAM2,GAMMI,GAMPL,H,
     2 P,PIMU,PIMU2,Q,R,RJL,RJL1,RJMU,RJP1,RJPL,RJTEMP,RY1,
     3 RYMU,RYMUP,RYTEMP,SUM,SUM1,TEMP,W,X2,XI,XI2,XMU,XMU2
C
      IF ((X .LE. 0.) .OR. (XNU .LT. 0.)) THEN
         WRITE (0,*) ' x,xnu:',X,XNU
         CALL ErrorStop(' bad arguments in bessjy')
      ENDIF
      PI= 4.D0*DATAN(1.D0)
C
C nl is the number of downward recurrences of the J's
C and upward recurrences of Y's.
C xmu lies between -1/2 and 1/2 for x .lt. XMIN,
C while it is chosen so that x is greater than the turning point
C for x .ge. XMIN.
C
      IF (X .LT. XMIN) THEN
         NL= INT(XNU+.5D0)
      ELSE
         NL= MAX(0, INT(XNU-X+1.5D0))
      ENDIF
      XMU= XNU-NL
      XMU2= XMU**2
      XI= 1.D0/X
      XI2= XI + XI
C
C The Wronskian.
C
      W= XI2/PI
C
C Evaluate CF1 by modified Lentz's method (\paragraph 5.2).
C isign keeps track of sign changes in the denominator.
C
      ISIGN= 1
      H= XNU*XI
      IF (H .LT. FPMIN) H= FPMIN
      B= XI2*XNU
      D= 0.D0
      C= H
      DO 11 I= 1, MAXIT, 1
         B= B+XI2
         D= B-D
         IF (ABS(D) .LT. FPMIN) D= FPMIN
         C= B-1.D0/C
         IF (ABS(C) .LT. FPMIN) C= FPMIN
         D= 1.D0/D
         DEL= C*D
         H= DEL*H
         IF (D .LT. 0.D0) ISIGN= -ISIGN
         IF (ABS(DEL-1.D0) .LT. EPS) GOTO 1
   11 CONTINUE
      WRITE (0,*) X,XNU,ABS(DEL-1.D0),EPS
      CALL ErrorStop(' x too large in bessjy; try asymptotic expansion')
    1 CONTINUE
C
C Initialize J_\nu and J_\nu^ '  for downward recurrence.
C
      RJL= ISIGN*FPMIN
      RJPL= H*RJL
C
C Store values for later rescaling
C
      RJL1= RJL
      RJP1= RJPL
      FACT= XNU*XI
      DO 12 L= NL, 1, -1
         RJTEMP= FACT*RJL+RJPL
         FACT= FACT-XI
         RJPL= FACT*RJTEMP-RJL
         RJL= RJTEMP
   12 CONTINUE
      IF (RJL .EQ. 0.D0) RJL= EPS
C
C Now have unnormalized J_\mu and J\mu^ ' .
C
      F= RJPL/RJL
      IF (X .LT. XMIN) THEN
C
C Use series
C
         X2= .5D0*X
         PIMU= PI*XMU
         IF (ABS(PIMU) .LT. EPS) THEN
            FACT= 1.D0
         ELSE
            FACT= PIMU/SIN(PIMU)
         ENDIF
         D= -LOG(X2)
         E= XMU*D
         IF (ABS(E) .LT. EPS) THEN
            FACT2= 1.D0
         ELSE
            FACT2= SINH(E)/E
         ENDIF
C
C Chebyshev evaluation of \Gamma_1 and \Gamma_2.
C
         CALL BESCHB(XMU,GAM1,GAM2,GAMPL,GAMMI)
C
C f_0.
C
         FF= 2.D0/PI*FACT*(GAM1*COSH(E)+GAM2*FACT2*D)
         E= EXP(E)
C
C p_0.
C
         P= E/(GAMPL*PI)
C
C q_0.
C
         Q= 1.D0/(E*PI*GAMMI)
         PIMU2= .5D0*PIMU
         IF (ABS(PIMU2) .LT. EPS) THEN
            FACT3= 1.D0
         ELSE
            FACT3= SIN(PIMU2)/PIMU2
         ENDIF
         R= PI*PIMU2*FACT3**2
         C= 1.D0
         D= -X2**2
         SUM= FF+R*Q
         SUM1= P
         DO 13 I= 1, MAXIT, 1
            FF= (I*FF+P+Q)/(I**2-XMU2)
            C= C*D/I
            P= P/(I-XMU)
            Q= Q/(I+XMU)
            DEL= C*(FF+R*Q)
            SUM= SUM+DEL
            DEL1= C*P-I*DEL
            SUM1= SUM1+DEL1
            IF (ABS(DEL) .LT. (1.D0+ABS(SUM))*EPS) GOTO 2
   13 CONTINUE
         CALL ErrorStop(' bessjy series failed to converge')
    2 CONTINUE
         RYMU= -SUM
         RY1= -SUM1*XI2
         RYMUP= XMU*XI*RYMU-RY1
C
C Equation (6.7.13).
C
         RJMU= W/(RYMUP-F*RYMU)
      ELSE
C
C Evaluate CF2 by modified Lentz's method (\paragraph 5.2).
C
         A= .25D0-XMU2
         P= -.5D0*XI
         Q= 1.D0
         BR= X+X
         BI= 2.D0
         FACT= A*XI/(P**2+Q**2)
         CR= BR+Q*FACT
         CI= BI+P*FACT
         DEN= BR**2 + BI**2
         DR= BR/DEN
         DI= -BI/DEN
         DLR= CR*DR - CI*DI
         DLI= CR*DI + CI*DR
         TEMP= P*DLR-Q*DLI
         Q= P*DLI + Q*DLR
         P= TEMP
         DO 14 I= 2, MAXIT, 1
            A= A+2*(I-1)
            BI= BI+2.D0
            DR= A*DR+BR
            DI= A*DI+BI
            IF ((ABS(DR) + ABS(DI)) .LT. FPMIN) DR= FPMIN
            FACT= A/(CR**2 + CI**2)
            CR= BR+CR*FACT
            CI= BI-CI*FACT
            IF ((ABS(CR) + ABS(CI)) .LT. FPMIN) CR= FPMIN
            DEN= DR**2 + DI**2
            DR= DR/DEN
            DI= -DI/DEN
            DLR= CR*DR - CI*DI
            DLI= CR*DI + CI*DR
            TEMP= P*DLR-Q*DLI
            Q= P*DLI + Q*DLR
            P= TEMP
            IF ((ABS(DLR-1.D0) + ABS(DLI)) .LT. EPS) GOTO 3
   14 CONTINUE
         CALL ErrorStop(' CF2 failed in bessjy')
    3 CONTINUE
C
C Equations (6.7.6) - (6.7.10)
C
         GAM= (P-F)/Q
         RJMU= SQRT(W/((P-F)*GAM+Q))
         RJMU= SIGN(RJMU,RJL)
         RYMU= RJMU*GAM
         RYMUP= RYMU*(P+Q/GAM)
         RY1= XMU*XI*RYMU-RYMUP
      ENDIF
      FACT= RJMU/RJL
C
C Scale original J_\nu and J_\nu^ ' .
C
      RJ= RJL1*FACT
      RJP= RJP1*FACT
      DO 15 I= 1, NL, 1
C
C Upward recurrence of Y_\nu.
C
         RYTEMP= (XMU+I)*XI2*RY1-RYMU
         RYMU= RY1
         RY1= RYTEMP
   15 CONTINUE
      RY= RYMU
      RYP= XNU*XI*RYMU-RY1
      RETURN
      END
C ../kazi/beschb.f
C23456789
      SUBROUTINE BESCHB(X,GAM1,GAM2,GAMPL,GAMMI)
      INTEGER NUSE1,NUSE2
      DOUBLE PRECISION GAM1,GAM2,GAMMI,GAMPL,X
      PARAMETER (NUSE1=7, NUSE2=8)
C
C Evaluates \Gamma_1 and \Gamma_2 by Chebyshev expansion
C for x \le 1/2.
C Also returns 1/\Gamma(1+x) and 1/\Gamma(1-x).
C If converting to double precision, set NUSE1 = 7, NUSE2 = 8.
C
      DOUBLEPRECISION XX,C1(7),C2(8),CHEBEV,RMIN1,REINS
      SAVE C1,C2
      DATA C1/-1.14 202 268 037 117 2D 0, 6.51 651 126 707 6D- 3,
     1 3.08 709 017 308 D- 4, -3.47 062 696 4 D- 6,
     2 6.94 376 4 D- 9, 3.67 80 D-11,
     3 -1.36 D-13 /
      DATA C2/ 1.84 374 058 730 090 6D 0, -.076 852 840 844 786 D0,
     1 1.27 192 713 665 5 D- 3, -4.97 173 670 4 D-6,
     2 -3.31 261 20 D- 8, 2.42 310 D-10,
     3 -1.70 D-13, -1. D-15/
C
C
C Multiply x by 2 to make range be -1 to 1, and then
C apply transforamtion for evaluating even Chebyshev series.
C
      XX= 8.D0*X**2 - 1.D0
      RMIN1= -1.
      REINS= 1.
      GAM1= CHEBEV(RMIN1,REINS,C1,NUSE1,XX)
      GAM2= CHEBEV(RMIN1,REINS,C2,NUSE2,XX)
      GAMPL= GAM2-X*GAM1
      GAMMI= GAM2+X*GAM1
      RETURN
      END
C ../kazi/kms.f
C23456789012345678901234567890123456789012345678901234567890123456789012
      DOUBLEPRECISION FUNCTION RNRM2(RNUE1,RNUE2,RMUE,THETA)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Numerische Integration
C
      DOUBLEPRECISION BTC931
      EXTERNAL BTC931
C
      COMMON /CI0R3/ RNUE1C,RNUE2C,RMUEC
C
      RNUE1C= RNUE1
      RNUE2C= RNUE2
      RMUEC= RMUE
      A= 1.E-8
      B= THETA
      CALL QSIMP(BTC931,A,B,S)
      RNRM2= S*RNUE1*(RNUE1+1.)
      RETURN
      END
C ***********
      DOUBLEPRECISION FUNCTION BTC931(THETA)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
C Naming rule:
C
C (bt) 29.th of
C (c) march
C '93
C 1.st function
C a b c d e f g h i j k l m n o p q r s t
C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
C
C u v w x y z
C 21 22 23 24 25 26 27 28 29 30 31
C
      COMMON /CI0R3/ RNUE1,RNUE2,RMUE
      DOUBLEPRECISION RLGF
      EXTERNAL RLGF
C
      IF (RNUE1 .EQ. RNUE2) THEN
         BTC931= SIN(THETA)*RLGF(THETA,RNUE1,RMUE)**2
      ELSE
         BTC931= SIN(THETA)*RLGF(THETA,RNUE1,RMUE)
     1 *RLGF(THETA,RNUE2,RMUE)
      ENDIF
      RETURN
      END
C **************
      SUBROUTINE QSIMP(FUNC,A,B,S)
      INTEGER JMAX
      DOUBLEPRECISION A,B,FUNC,S,EPS
      EXTERNAL FUNC
      PARAMETER (EPS=1.E-6, JMAX=20)
C USES trapzd
C
C Returns as S the integral of the function FUNC from A to B.
C The parameters EPS can be set to the desired fractional accuracy
C and JMAX so that 2 to the power JMAX-1 is the maximum allowed
C number of steps.
C Integration is performed by Simpson's rule.
C
      INTEGER J
      DOUBLEPRECISION OS,OST,ST
C
      OST= -1.E30
      OS= -1.E30
      DO 11 J= 1, JMAX, 1
         CALL TRAPZD(FUNC,A,B,ST,J)
C
C Compare equation (4.2.4), above
C
         S= (4.*ST-OST)/3.
         IF (ABS(S-OS) .LT. EPS*ABS(OS)) RETURN
         OS= S
         OST= ST
   11 CONTINUE
      WRITE (0,*) ' too many  steps in QSIMP..'
      STOP ' QSIMP'
      END
C *************
      SUBROUTINE TRAPZD(FUNC,A,B,S,N)
      INTEGER N
      DOUBLEPRECISION A,B,S,FUNC
      EXTERNAL FUNC
C
C This routine computes the N.th stage of refinement of an extrapolated
C trapezoidal rule. FUNC is input as the name of the function to be
C integrated between limits A and B, also input. When called with N=1,
C the routine returns as S the crudest estimate of $\int_A^B FUNC(x) dx$.
C Subsequent calls with N=2,3,... (in that sequential order) will
C improve the accuracy of S by adding $2^ N-2 $ additional interior
C points.
C S should not be modified between sequential calls.
C
      INTEGER IT,J
      DOUBLEPRECISION DEL,SUM,TNM,X
C
      IF (N .EQ. 1) THEN
         S= .5*(B-A)*(FUNC(A)+FUNC(B))
      ELSE
         IT= 2**(N-2)
         TNM= IT
C
C This is the spacing of the points to be added.
C
         DEL= (B-A)/TNM
         X= A+.5*DEL
         SUM= 0.
         DO 11 J= 1, IT, 1
            SUM= SUM+FUNC(X)
            X= X+DEL
   11 CONTINUE
C
C This replaces S by its refined value.
C
         S= .5*(S+(B-A)*SUM/TNM)
      ENDIF
      RETURN
      END
C ***********
      DOUBLEPRECISION FUNCTION RNRM(RNUE,RMUE,THETA)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
      DOUBLEPRECISION RLGF,RLGFS,RLGFNS,GAMMLN
      EXTERNAL RLGF,RLGFS,RLGFNS,GAMMLN
      COMMON /CI1/ IERR
C
      IF (ABS(1.+COS(THETA)) .LE. 1.E-6) THEN
         RDUM1= RNUE+RMUE+1.
         RDUM2= RNUE-RMUE+1.
         RDUM= 2./(2.*RNUE+1.)*EXP(GAMMLN(RDUM1)-GAMMLN(RDUM2))
         RNRM= RDUM
         RETURN
      ENDIF
      RDUM= - RNUE*(RNUE+1.)/(2.*RNUE+1.)
     1 *(RLGFNS(0,THETA,RNUE,RMUE)*RLGFS(THETA,RNUE,RMUE)
     2 -RLGFNS(1,THETA,RNUE,RMUE)*RLGF (THETA,RNUE,RMUE)
     3 )
      IF (IERR .NE. 0) THEN
C IF (.TRUE.) THEN
         RDUM2= RNRM2(RNUE,RNUE,RMUE,THETA)
         WRITE (0,*) ' rnrm: analytisch, numerisch, ana/num:',
     1 RDUM,RDUM2,RDUM/RDUM2
         RDUM= RDUM2
         IERR= 0
      ENDIF
      RNRM= RDUM
      RETURN
      END
C ***********
      DOUBLECOMPLEX FUNCTION CNRM(CNUE,CMUE,THETA)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
C
      DOUBLECOMPLEX CLGF,CLGFS,CLGFNS
      EXTERNAL CLGF,CLGFS,CLGFNS
C
      IF (ABS(DIMAG(CNUE))+ABS(DIMAG(CMUE)) .EQ. 0.) THEN
         CNRM= RNRM(CNUE,CMUE,THETA)
         RETURN
      ENDIF
      Z= COS(THETA)
      CNRM= - CNUE*(CNUE+1.)/(CNUE+CNUE+1.)
     1 *(CLGFNS(0,Z,CNUE,CMUE)*CLGFS(Z,CNUE,CMUE)
     2 -CLGFNS(1,Z,CNUE,CMUE)*CLGF (Z,CNUE,CMUE)
     3 )
      RETURN
      END
C ***********
      SUBROUTINE K MS(II,JJ,CM,MAZI,THETA,CTJ,CTI,IO)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      DIMENSION CM(II,*),CTJ(*),CTI(*)
C
C This is the heart of almost everything,
C here are the integrals computed
C
      COMMON /STDIO/ IIN,IOUT,IERR
      DIMENSION PI(500),DPI(500)
      LOGICAL FLAG
C
C WRITE (IERR,*)
C WRITE (IERR,*) ' ctj:',(DBLE(CTJ(J)),J=1,JJ,1)
C WRITE (IERR,*) ' cti:',(DBLE(CTI(I)),I=1,II,1)
C WRITE (IERR,*) ' theta:',THETA*45./DATAN(1.D0)
      IF (II .GT. 500) CALL ErrorStop(' K MS: II .GT. 500 ....')
      RMUE= DBLE(MAZI)
C
C Check, whether the two arrays are the same (flag)
C
      FLAG= .TRUE.
      DO 1 I= 1, MIN0(II,JJ), 1
C FLAG= FLAG .AND. (CTJ(I) .EQ. CTI(I))
         FLAG= FLAG .AND. (ABS(CTJ(I)- CTI(I)) .LE. 1.E-4)
         IF (.NOT. FLAG) GOTO 2
    1 CONTINUE
    2 CONTINUE
      IF (FLAG) THEN
C
C Diagonal matrix
C
         CALL MNULL(JJ,II,CM)
         DO 41 I= 1, MIN0(II,JJ), 1
C CM(I,I)= RNRM(CTI(I),RMUE,THETA)
            CM(I,I)= DIMAG(CTI(I))
C write (ierr,*) ' k ms: ',i,cm(i,i),DIMAG(CTI(I))**2
   41 CONTINUE
      ELSE IF (IO .EQ. 0) THEN
         DO 10 I= 1, II, 1
             PI(I)= RLGF (THETA,CTI(I),RMUE)
            DPI(I)= RLGFS(THETA,CTI(I),RMUE)
   10 CONTINUE
         DO 40 J= 1, JJ, 1
            PJJ= RLGF (THETA,CTJ(J),RMUE)
            DPJJ= RLGFS(THETA,CTJ(J),RMUE)
            RTJ= CTJ(J)
            DO 50 I= 1, II, 1
               RTI= CTI(I)
               RTO= RTI
               CM(I,J)= - RTO*(RTO+1.)
     1 /((RTJ-RTI)*(RTJ+RTI+1.))
     2 *(PJJ*DPI(I)-PI(I)*DPJJ)
   50 CONTINUE
   40 CONTINUE
      ELSE
         DO 110 I= 1, JJ, 1
             PI(I)= RLGF (THETA,CTI(I),RMUE)
            DPI(I)= RLGFS(THETA,CTI(I),RMUE)
  110 CONTINUE
         DO 140 J= 1, II, 1
            PJJ= RLGF (THETA,CTJ(J),RMUE)
            DPJJ= RLGFS(THETA,CTJ(J),RMUE)
            RTJ= CTJ(J)
            DO 150 I= 1, JJ, 1
               RTI= CTI(I)
               RTO= RTI
               CM(J,I)= - RTO*(RTO+1.)
     1 /((RTJ-RTI)*(RTJ+RTI+1.))
     2 *(PJJ*DPI(I)-PI(I)*DPJJ)
  150 CONTINUE
  140 CONTINUE
      ENDIF
      RETURN
      END
C **********************
      SUBROUTINE K MEEM(II,JJ,CM,MAZI,THETA,CTJ,CTI)
      IMPLICIT INTEGER (I-N)
      IMPLICIT DOUBLEPRECISION (A,B,D-H,O-Y)
      IMPLICIT DOUBLECOMPLEX (C,Z)
      DIMENSION CM(II,*),CTI(*),CTJ(*)
C
      DIMENSION PI(500)
C
      IF (II .GT. 500) CALL ErrorStop(' K MEEM: II .GT. 500')
      RMUE= DBLE(MAZI)
      DO 10 I= 1, II, 1
         PI(I)= RLGF(THETA,CTI(I),RMUE)
   10 CONTINUE
      DO 40 J= 1, JJ, 1
         RDUM= RMUE*RLGF(THETA,CTJ(J),RMUE)
         DO 50 I= 1, II, 1
            CM(I,J)= RDUM*PI(I)
   50 CONTINUE
   40 CONTINUE
      RETURN
      END
C ../lib/ErrorStop.f
      SUBROUTINE ErrorStop(S)
      CHARACTER*(*) S
      WRITE (0,*) S
      STOP
      END
C*******************
      SUBROUTINE L855(S1,S2)
      CHARACTER*(*) S1, S2
      WRITE (0,10) S1, S2
   10 FORMAT(' FEHLER NUMMER ',A,' IN ROUTINE ',A)
      WRITE (0,*) ' ABBRUCH.'
      STOP
      END
