PROGRAM ZEROBJ IMPLICIT NONE DOUBLE PRECISION a,b,pnu,eps,xcert(1000),xcmal(3), c gamba,talpha INTEGER i,numt,j,k,com,itct(1000),itmal(3) write(*,*)'a,b,nu,gamba,tan(alpha),eps' read(*,*)a,b,pnu,gamba,talpha,eps CALL genbesj(a,b,pnu,gamba,talpha,eps,xcert,xcmal,itct c ,itmal,numt,com) write(*,30)'Zeros','Iterations','Number of zeros' DO i=1,numt write(*,31)xcert(i),itct(i),numt ENDDO write(*,*)' ' IF(com.gt.0) write(*,32)'Zeros with acc. loss', c 'Iterations' DO i=1,com write(*,33)xcmal(i),itmal(i) ENDDO 30 format(a8,16x,a10,5x,a16) 31 format(d22.16,5x,i5,15x,i5) 32 format(a20,4x,a10) 33 format(d22.16,5x,i5) END SUBROUTINE genbesj(a,b,pnu,gamba,talpha,eps, c xcert,xcmal,itct,itmal,numt,com) IMPLICIT NONE DOUBLE PRECISION a,b,pnu,gamba,eps,xcer(1000) DOUBLE PRECISION xcert(1000),li(1:7),ui(1:7), c x0,nuga,hfu,xcmal(3),talpha DOUBLE PRECISION cy1(1), cy2(1), cy3(1), cy4(1), cw1(3), cw2(3) DOUBLE PRECISION cyi1(1), cyi2(1), cyi3(1), cyi4(1), c xt1,xt2,fxt1,fxt2,sip INTEGER i,j,co,cot,numt,signo(1:7),num,com,nz,ierro,itct(1000) c ,itc(1000),itmal(3) c c Warning: this is a preliminary version of the program c Additional error handling has to be incorporated c CALL intervals(a,b,pnu,gamba,co,li,ui,signo,talpha) numt=0 do i=1,co num=0 if(li(i).lt.ui(i))then CALL besjz(signo(i),li(i),ui(i),pnu,gamba, c talpha,eps,xcer,itc,num) do j=numt+1,num+numt xcert(j)=xcer(j-numt) itct(j)=itc(j-numt) enddo endif numt=numt+num enddo if(abs(pnu).gt.abs(gamba))then nuga=sqrt(pnu**2-gamba**2) if(a.lt.nuga)then xt1=nuga*(1+2.d-16) fxt1=abs(xt1**2-nuga**2) xt2=nuga*(1-2.d-16) fxt2=abs(xt2**2-nuga**2) c write(*,*)'function values near the double point' c write(*,*)fxt1*hfu(pnu,talpha,gamba,xt1),fxt2*hfu c c (pnu,talpha,gamba,xt2) endif endif com=0 i=0 do while(i.lt.numt) i=i+1 sip=(xcert(i)**2-pnu**2+gamba**2) if(abs(sip*hfu(pnu,talpha,gamba c ,xcert(i))).gt.eps)then com=com+1 xcmal(com)=xcert(i) itmal(com)=itct(i) numt=numt do j=i,numt xcert(j)=xcert(j+1) itct(j)=itct(j+1) enddo i=i-1 numt=numt-1 endif enddo RETURN END SUBROUTINE besjz(j,a,b,pnu,gamba,talpha,eps,xcer,itc,num) IMPLICIT NONE DOUBLE PRECISION a,b,xm,xc,xcer(1000),pnu,eps,delta,omega DOUBLE PRECISION h,omega2,dpi,dpi2,atast,hm,ss,sa DOUBLE PRECISION dev,dest,omegam,omegab,ffc,fc,coef,hfut DOUBLE PRECISION gamba,omep,hfu,singu,l1,si,h1t,h2t,talpha DOUBLE PRECISION sip, fsip INTEGER j,i,num,k,iter,isal,itc(1000) dpi=dacos(-1.d0) if(a.ge.b)then write(*,*)'a should be smaller than b' STOP endif if(int(pnu).eq.pnu)pnu=abs(pnu) dev=1.D0 if(j.eq.1)then xm=a xc=b else xm=b xc=a endif i=0 omega2=coef(pnu,gamba,xc) omegam=coef(pnu,gamba,xm) if (j.gt.0) then omegab=omega2 else omegab=omegam endif ss=omega2*omegam if (ss.lt.0) then k=0 elseif (omegab.le.0) then k=-1 else k=1 end if DO WHILE((j*(xc-xm).gt.0).AND.(k.GE.0)) iter=0 dev=eps+1 isal=0 hfut=1 sip=1 DO WHILE ((dev.gt.eps).and.(j*(xc-xm).gt.0).AND.(k.GE.0). c and.(abs(sip*hfut).gt.1.d-19)) iter=iter+1 IF(iter.GT.1000)THEN WRITE(*,*)'convergence failure' STOP ENDIF sip=(xc**2-pnu**2+gamba**2) hfut=hfu(pnu,talpha,gamba,xc) si=sip/abs(sip) h=dsqrt(omep(pnu,gamba,xc))*si*hfut omega=dsqrt(omega2) atast=datan(h) dest=atast/omega dev=ABS(dest)/xc if (isal.eq.1) dev=0.5*eps if (log(dev).lt.0.25d0*log(eps)) isal=1 if(j*dest.lt.0) then if(dev.gt.1.d-10) dest=dest+j*dpi/omega endif xc=xc-dest omega2=coef(pnu,gamba,xc) IF(omega2.LE.0.D0) k=-1 ENDDO IF ((j*(xc-xm).gt.0).AND.(k.GE.0)) THEN i=i+1 xcer(i)=xc itc(i)=iter xc=xc-j*dpi/omega omega2=coef(pnu,gamba,xc) IF(omega2.LE.0.D0) k=-1 ENDIF ENDDO if(k.lt.0) then h1t=hfu(pnu,talpha,gamba,xm) h2t=hfu(pnu,talpha,gamba,xc) si=(xc**2-pnu**2+gamba**2) si=si/abs(si) h=dsqrt(-omep(pnu,gamba,xc))*si*h2t if((j*h.gt.0).and.(h1t*h2t.lt.0))then iter=0 dev=eps+1 omega=sqrt(-omega2) isal=0 DO WHILE ((dev.gt.eps).and.(abs(h).lt.1).and. c (j*(xc-xm).gt.0)) iter=iter+1 IF(iter.GT.1000)THEN WRITE(*,*)'convergence failure' STOP ENDIF si=(xc**2-pnu**2+gamba**2) si=si/abs(si) h=dsqrt(-omep(pnu,gamba,xc))*si*hfu(pnu,talpha,gamba,xc) omega=dsqrt(-omega2) if(abs(h).lt.1)then atast=datanh(h) dest=atast/omega dev=ABS(dest)/xc if (isal.eq.1) dev=0.5*eps if (log(dev).lt.0.5d0*log(eps)) isal=1 xc=xc-dest omega2=coef(pnu,gamba,xc) sip=(xc**2-pnu**2+gamba**2) endif ENDDO IF (dev.lt.eps) THEN i=i+1 xcer(i)=xc itc(i)=iter ENDIF endif endif num=i RETURN END SUBROUTINE intervals(ai,bi,nu,g,co,li,ui,signo,talpha) implicit none double precision pi,d,lambda,g,c,q,r,delta,Ad,x,the,sqq,nu2 double precision x1,x2,x3,nu,si,si2,xt(1:7),alam,limi double precision li(1:7),ui(1:7),xpp,a,b,al,bl,ai,bi,talpha double precision PP,QQ,RR,sl,sr integer signo(1:7) integer i,mod,j,k,ind,co,nogo,ja,jb c mod=1 BesselJ c mod=0 other cases nogo=0 mod=0 nu2=nu*nu lambda=nu2-g**2 if(lambda.ne.0)then si=lambda/abs(lambda) pi=acos(-1.d0) d=(3./4-2*g+nu2) a=si*(2*g-3*nu2+23./4)/d b=3.*(nu2-0.25)/d c=si*(0.25-nu2)/d q=(a**2-3*b)/9. r=(2.*a**3-9.*a*b+27.*c)/54. delta=r**2-q**3 limi=max(mod*si,0.d0) i=0 if (delta.gt.0) then Ad=-r/abs(r)*(abs(r)+sqrt(delta))**(1./3.) x=(Ad+Q/Ad)-a/3. if (x.gt.limi) then i=i+1 xt(i)=x endif else the=acos(r/q**(3./2.)) sqq=sqrt(q) x1=-2.*sqq*cos(the/3.)-a/3. if(x1.gt.limi)then i=i+1 xt(i)=x1 endif x2=-2.*sqq*cos((the+2*pi)/3.)-a/3. if(x2.gt.limi)then i=i+1 xt(i)=x2 endif x3=-2*sqq*cos((the-2*pi)/3.)-a/3. if(x3.gt.limi)then i=i+1 xt(i)=x3 endif endif alam=abs(lambda) al=ai**2/alam bl=bi**2/alam if(lambda.gt.0)then if(mod.eq.0)then i=i+1 xt(i)=1.d0+1.d-15 i=i+1 xt(i)=1.d0-1.d-15 elseif(al.lt.1.d0) then if(bl.gt.1.d0)then al=1.d0+1.d-15 else nogo=1 endif endif endif i=i+1 xt(i)=al i=i+1 xt(i)=bl if(nogo.eq.0)then do ind=i,2,-1 do k=1,ind-1 if(xt(k).gt.xt(k+1)) then xpp=xt(k) xt(k)=xt(k+1) xt(k+1)=xpp endif enddo enddo ja=1 if(xt(1).lt.al)then do while(xt(ja).lt.al) ja=ja+1 enddo else ja=1 endif jb=ja if(xt(i).gt.bl)then do while(xt(jb).lt.bl) jb=jb+1 enddo else jb=i endif co=0 do k=ja,jb-1 if(abs(1.d0-xt(k)/xt(k+1)).gt.1.d-9)then co=co+1 li(co)=xt(k) ui(co)=xt(k+1) endif enddo do j=1,co x=(li(j)+ui(j))/2 si2=(x-si)*d*(x**3+a*x**2+b*x+c) signo(j)=int(si2/abs(si2)) li(j)=sqrt(alam*li(j)) ui(j)=sqrt(alam*ui(j)) enddo PP=-3.d0*nu2+2.d0*g*(g+1)-0.75d0 QQ=(3.d0*nu2-g*(g+2.d0)-2.5d0)*lambda RR=(0.25d0-nu2)*lambda**2 do j=1,co x=li(j)**2 sl=x**3+PP*x**2+QQ*x+RR x=ui(j)**2 sr=x**3+PP*x**2+QQ*x+RR enddo endif else co=1 li(1)=ai ui(1)=bi signo(1)=0 if(nu.eq.g)then signo(1)=int((nu-1.d0)**2-0.25d0) else signo(1)=int((nu+1.d0)**2-0.25d0) endif if(signo(1).ne.0) then signo(1)=signo(1)/abs(signo(1)) else signo(1)=1 endif endif if(talpha.ne.0)then if(li(1).lt.1.d-6) li(1)=1.d-6 else li(1)=max(li(1),1.d-50) endif c write(*,*)'The intervals are' c do j=1,co c write(*,*)li(j),ui(j),signo(j) c enddo c write(*,*)'-------------' c write(*,*)'The zeros are' return end DOUBLE PRECISION FUNCTION hfu(nu,talpha,gamba,x) implicit none double precision nu,gamba,x,o2,g2,x2,r,d,e,m,n,n2,si,fc, c talpha x2=x*x n2=nu*nu g2=gamba*gamba d=nu+gamba e=-x m=-x2**2+d*(2*nu-gamba-0.5d0)*x2-d*(n2-g2)*(nu+0.5d0) n=x*((0.5d0-gamba)*x2+(n2-g2)*(gamba+0.5d0)) r=fc(x,nu+1.d0,talpha) hfu=(d+e*r)/(m+n*r) RETURN END DOUBLE PRECISION FUNCTION coef(nu,gamba,x) implicit none double precision nu,gamba,x,n2,g2,x2,omep x2=x*x g2=gamba*gamba n2=nu*nu coef=omep(nu,gamba,x)/x2/(x2-n2+g2)**2 RETURN END DOUBLE PRECISION FUNCTION omep(nu,gamba,x) implicit none double precision nu,gamba,x,P,Q,R,g2,x2,n2 n2=nu*nu g2=gamba*gamba x2=x*x P=(-3*n2+2*g2+2*gamba-0.75d0) Q=(3*n2-g2-2*gamba-2.5d0)*(n2-g2) R=(0.25d0-n2)*(n2-g2)**2 omep=x2**3+P*x2**2+Q*x2+R RETURN END DOUBLE PRECISION FUNCTION fc(x,pnu,talpha) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC fc=(cos(alpha)*J(pnu,x)-sin(alpha)*Y(pnu,x))/ CCCC (cos(alpha)*J(pnu-1,x)-sin(alpha)*Y(pnu-1,x)) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IMPLICIT NONE DOUBLE PRECISION x, pnu, talpha DOUBLE PRECISION cy1(1), cy2(1), cy3(1), cy4(1), cw1(3), cw2(3) DOUBLE PRECISION cyi1(1), cyi2(1), cyi3(1), cyi4(1) DOUBLE PRECISION salpha,dpi,c,talphai DOUBLE PRECISION fj1, fj2, fy1, fy2,pnum,pnumm DOUBLE PRECISION fj1f, fj2f, fy1f, fy2f INTEGER nz, ierro dpi=acos(-1.d0) if(pnu.le.0) then pnum=abs(pnu) pnumm=abs(pnu)+1 elseif(pnu.lt.1)then pnum=pnu pnumm=abs(pnu-1) else pnum=pnu pnumm=pnu-1 endif CALL zbesj(x, 0.d0, pnum, 1, 1, cy1, cyi1, nz, ierro) fj1=cy1(1) CALL zbesy(x, 0.d0, pnum, 1, 1, cy2, cyi2, nz, cw1, cw2, ierro) fy1=cy2(1) CALL zbesj(x, 0.d0, pnumm, 1, 1, cy3, cyi3, nz, ierro) fj2=cy3(1) CALL zbesy(x, 0.d0, pnumm, 1, 1, cy4, cyi4, nz, cw1, cw2, ierro) fy2=cy4(1) if(pnu.le.0)then fj1f=cos(pnum*dpi)*fj1-sin(pnum*dpi)*fy1 fy1f=sin(pnum*dpi)*fj1+cos(pnum*dpi)*fy1 fj2f=cos(pnumm*dpi)*fj2-sin(pnumm*dpi)*fy2 fy2f=sin(pnumm*dpi)*fj2+cos(pnumm*dpi)*fy2 elseif(pnu.lt.1)then fj1f=fj1 fy1f=fy1 fj2f=cos(pnum*dpi)*fj2-sin(pnum*dpi)*fy2 fy2f=sin(pnum*dpi)*fj2+cos(pnum*dpi)*fy2 else fj1f=fj1 fy1f=fy1 fj2f=fj2 fy2f=fy2 endif c=1.d0 talphai=talpha if(abs(talpha).gt.1.d250)then c=0.d0 talphai=1.d0 endif fc=(c*fj1f-talphai*fy1f)/(c*fj2f-talphai*fy2f) END FUNCTION DOUBLE PRECISION FUNCTION D1MACH(I) C***BEGIN PROLOGUE D1MACH C***DATE WRITTEN 750101 (YYMMDD) C***REVISION DATE 890213 (YYMMDD) C***CATEGORY NO. R1 C***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(R1MACH-S D1MACH-D), C MACHINE CONSTANTS C***AUTHOR FOX, P. A., (BELL LABS) C HALL, A. D., (BELL LABS) C SCHRYER, N. L., (BELL LABS) C***PURPOSE Returns 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 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 C Assume double precision numbers are represented in the T-digit, C base-B form C C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and C EMIN .LE. E .LE. EMAX. C C The values of B, T, EMIN and EMAX are provided in I1MACH as C follows: C I1MACH(10) = B, the base. 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 D1MACH(1) - D1MACH(4) should be checked for consistency C with the local operating system. C 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 INTEGER SMALL(4) INTEGER LARGE(4) INTEGER RIGHT(4) INTEGER DIVER(4) INTEGER LOG10(4) C DOUBLE PRECISION DMACH(5) SAVE DMACH C EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE APOLLO C C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM C C DATA SMALL(1) / ZC00800000 / C DATA SMALL(2) / Z000000000 / C DATA LARGE(1) / ZDFFFFFFFF / C DATA LARGE(2) / ZFFFFFFFFF / C DATA RIGHT(1) / ZCC5800000 / C DATA RIGHT(2) / Z000000000 / C DATA DIVER(1) / ZCC6800000 / C DATA DIVER(2) / Z000000000 / C DATA LOG10(1) / ZD00E730E7 / C DATA LOG10(2) / ZC77800DC0 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O0000000000000000 / C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O0007777777777777 / C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O7770000000000000 / C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O7777777777777777 / C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE C C DATA SMALL(1) / Z"3001800000000000" / C DATA SMALL(2) / Z"3001000000000000" / C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / C DATA LARGE(2) / Z"4FFE000000000000" / C DATA RIGHT(1) / Z"3FD2800000000000" / C DATA RIGHT(2) / Z"3FD2000000000000" / C DATA DIVER(1) / Z"3FD3800000000000" / C DATA DIVER(2) / Z"3FD3000000000000" / C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / C DATA LOG10(2) / Z"3FFFF7988F8959AC" / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C C DATA SMALL(1) / 00564000000000000000B / C DATA SMALL(2) / 00000000000000000000B / C DATA LARGE(1) / 37757777777777777777B / C DATA LARGE(2) / 37157777777777777777B / C DATA RIGHT(1) / 15624000000000000000B / C DATA RIGHT(2) / 00000000000000000000B / C DATA DIVER(1) / 15634000000000000000B / C DATA DIVER(2) / 00000000000000000000B / C DATA LOG10(1) / 17164642023241175717B / C DATA LOG10(2) / 16367571421742254654B / C C MACHINE CONSTANTS FOR THE CELERITY C1260 C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE CONVEX C-1 C C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / C DATA LARGE(1), LARGE(2) / '7FFFFFFF'X,'FFFFFFFF'X / C DATA RIGHT(1), RIGHT(2) / '3CC00000'X,'00000000'X / C DATA DIVER(1), DIVER(2) / '3CD00000'X,'00000000'X / C DATA LOG10(1), LOG10(2) / '3FF34413'X,'509F79FF'X / C C MACHINE CONSTANTS FOR THE CRAY-1 C C DATA SMALL(1) / 201354000000000000000B / C DATA SMALL(2) / 000000000000000000000B / C DATA LARGE(1) / 577767777777777777777B / C DATA LARGE(2) / 000007777777777777774B / C DATA RIGHT(1) / 376434000000000000000B / C DATA RIGHT(2) / 000000000000000000000B / C DATA DIVER(1) / 376444000000000000000B / C DATA DIVER(2) / 000000000000000000000B / C DATA LOG10(1) / 377774642023241175717B / C DATA LOG10(2) / 000007571421742254654B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC DMACH(5) C C DATA SMALL / 20K, 3*0 / C DATA LARGE / 77777K, 3*177777K / C DATA RIGHT / 31420K, 3*0 / C DATA DIVER / 32020K, 3*0 / C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / C C MACHINE CONSTANTS FOR THE ELXSI 6400 C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) C C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES C C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / C C MACHINE CONSTANTS FOR THE HP 2100 C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / C C MACHINE CONSTANTS FOR THE HP 2100 C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 0 / C DATA SMALL(3), SMALL(4) / 0, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177777B / C DATA LARGE(3), LARGE(4) / 177777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / C DATA RIGHT(3), RIGHT(4) / 0, 225B / C DATA DIVER(1), DIVER(2) / 40000B, 0 / C DATA DIVER(3), DIVER(4) / 0, 227B / C DATA LOG10(1), LOG10(2) / 46420B, 46502B / C DATA LOG10(3), LOG10(4) / 76747B, 176377B / C C MACHINE CONSTANTS FOR THE HP 9000 C C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / 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 SMALL(1), SMALL(2) / Z00100000, Z00000000 / C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / C C MACHINE CONSTANTS FOR THE IBM PC C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. C c DATA SMALL(1),SMALL(2) / 2002288515, 1050897 / DATA LARGE(1),LARGE(2) / 1487780761, 2146426097 / DATA RIGHT(1),RIGHT(2) / -1209488034, 1017118298 / DATA DIVER(1),DIVER(2) / -1209488034, 1018166874 / DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) C C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) C C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1), SMALL(2) / 8388608, 0 / C DATA LARGE(1), LARGE(2) / 2147483647, -1 / C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / C DATA DIVER(1), DIVER(2) / 620756992, 0 / C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / C C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1), SMALL(2) / 128, 0 / C DATA SMALL(3), SMALL(4) / 0, 0 / C DATA LARGE(1), LARGE(2) / 32767, -1 / C DATA LARGE(3), LARGE(4) / -1, -1 / C DATA RIGHT(1), RIGHT(2) / 9344, 0 / C DATA RIGHT(3), RIGHT(4) / 0, 0 / C DATA DIVER(1), DIVER(2) / 9472, 0 / C DATA DIVER(3), DIVER(4) / 0, 0 / C DATA LOG10(1), LOG10(2) / 16282, 8346 / C DATA LOG10(3), LOG10(4) / -31493, -12296 / C C DATA SMALL(1), SMALL(2) / O000200, O000000 / C DATA SMALL(3), SMALL(4) / O000000, O000000 / C DATA LARGE(1), LARGE(2) / O077777, O177777 / C DATA LARGE(3), LARGE(4) / O177777, O177777 / C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / C DATA DIVER(1), DIVER(2) / O022400, O000000 / C DATA DIVER(3), DIVER(4) / O000000, O000000 / C DATA LOG10(1), LOG10(2) / O037632, O020232 / C DATA LOG10(3), LOG10(4) / O102373, O147770 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS C c data dmach(1) / 2.22507 38585 072012 d-308 / c data dmach(2) / 1.79769 31348 623158 d+308 / c data dmach(3) / 2.22044 60492 503131 d-16 / c data dmach(4) / 4.44089 20985 006262 d-16 / c data dmach(5) / 0.30102 99956 639812 / C C DATA SMALL(1), SMALL(2) / Z'00100000',Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF',Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CB00000',Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CC00000',Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413',Z'509F79FF' / C C MACHINE CONSTANTS FOR THE SUN C C from SLATEC CML committee - work for Sun3, Sun4, and Sparc C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C from Sun Microsystems - work for Sun 386i C C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000' / C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000' / C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000' / C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413' / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER C C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / C C MACHINE CONSTANTS FOR VAX 11/780 C (EXPRESSED IN INTEGER AND HEXADECIMAL) C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS C C DATA SMALL(1), SMALL(2) / 128, 0 / C DATA LARGE(1), LARGE(2) / -32769, -1 / C DATA RIGHT(1), RIGHT(2) / 9344, 0 / C DATA DIVER(1), DIVER(2) / 9472, 0 / C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / C C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / C C MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING) C (EXPRESSED IN INTEGER AND HEXADECIMAL) C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS C C DATA SMALL(1), SMALL(2) / 16, 0 / C DATA LARGE(1), LARGE(2) / -32769, -1 / C DATA RIGHT(1), RIGHT(2) / 15552, 0 / C DATA DIVER(1), DIVER(2) / 15568, 0 / C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / C C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / C C 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 = DMACH(I) RETURN C END SUBROUTINE FDUMP C***BEGIN PROLOGUE FDUMP C***DATE WRITTEN 790801 (YYMMDD) C***REVISION DATE 861211 (YYMMDD) C***CATEGORY NO. R3 C***KEYWORDS LIBRARY=SLATEC(XERROR),TYPE=ALL(FDUMP-A),ERROR 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 RETURN END c----------------------------------------------------------------- C>>> ZBSUBS.FOR: Double precision subroutines c----------------------------------------------------------------- SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESH C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801, 930101 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX 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 COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 C OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX C Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. C ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS C C CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1. C C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND C LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE C NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). C C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), C -PT.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 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 IN THE SEQUENCE, N.GE.1 C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS 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 DUE C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR C Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY 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 TOO C LARGE OR CABS(Z) TOO SMALL OR BOTH C IERR=3, CABS(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, CABS(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)*CEXP( PI*FNU*I) C H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) C I**2=-1 C C CAN BE USED. C C IN MOST COMPLEX 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=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 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 COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0D-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(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(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 COMPLEX 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 COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, C PP 265-273. C C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH C***END PROLOGUE ZBESH C C COMPLEX CY,Z,ZN,ZT,CSGN EXTERNAL ZABS DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, * CSGNR, CSGNI INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, * MM, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CYR(N), CYI(N) C DATA HPI /1.57079632679489662D0/ C C***FIRST EXECUTABLE STATEMENT ZBESH IERR = 0 NZ=0 IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 IF (FNU.LT.0.0D0) 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(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 FN = FNU + DBLE(FLOAT(NN-1)) MM = 3 - M - M FMM = DBLE(FLOAT(MM)) ZNR = FMM*ZI ZNI = -FMM*ZR C----------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(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 = D1MACH(1)*1.0D+3 IF (AZ.LT.UFL) GO TO 230 IF (FNU.GT.FNUL) GO TO 90 IF (FN.LE.1.0D0) GO TO 70 IF (FN.GT.2.0D0) GO TO 60 IF (AZ.GT.TOL) GO TO 70 ARG = 0.5D0*AZ ALN = -FN*DLOG(ARG) IF (ALN.GT.ELIM) GO TO 230 GO TO 70 60 CONTINUE CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, * ALIM) IF (NUF.LT.0) GO TO 230 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 140 70 CONTINUE IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .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 ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM) GO TO 110 C----------------------------------------------------------------------- C LEFT HALF PLANE COMPUTATION C----------------------------------------------------------------------- 80 CONTINUE MR = -MM CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, * TOL, ELIM, ALIM) IF (NW.LT.0) GO TO 240 NZ=NW GO TO 110 90 CONTINUE C----------------------------------------------------------------------- C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL C----------------------------------------------------------------------- MR = 0 IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR. * M.NE.2)) GO TO 100 MR = -MM IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100 ZNR = -ZNR ZNI = -ZNI 100 CONTINUE CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 240 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) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 C----------------------------------------------------------------------- SGN = DSIGN(HPI,-FMM) C----------------------------------------------------------------------- C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN RHPI = 1.0D0/SGN C ZNI = RHPI*DCOS(ARG) C ZNR = -RHPI*DSIN(ARG) CSGNI = RHPI*DCOS(ARG) CSGNR = -RHPI*DSIN(ARG) IF (MOD(INUH,2).EQ.0) GO TO 120 C ZNR = -ZNR C ZNI = -ZNI CSGNR = -CSGNR CSGNI = -CSGNI 120 CONTINUE ZTI = -FMM RTOL = 1.0D0/TOL ASCLE = UFL*RTOL DO 130 I=1,NN C STR = CYR(I)*ZNR - CYI(I)*ZNI C CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR C CYR(I) = STR C STR = -ZNI*ZTI C ZNI = ZNR*ZTI C ZNR = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 135 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 135 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL STR = -CSGNI*ZTI CSGNI = CSGNR*ZTI CSGNR = STR 130 CONTINUE RETURN 140 CONTINUE IF (ZNR.LT.0.0D0) GO TO 230 RETURN 230 CONTINUE NZ=0 IERR=2 RETURN 240 CONTINUE IF(NW.EQ.(-1)) GO TO 230 NZ=0 IERR=5 RETURN 260 CONTINUE NZ=0 IERR=4 RETURN END SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESI C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801, 930101 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS I-BESSEL FUNCTION,COMPLEX 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 COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED C FUNCTIONS C C CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z) J = 1,...,N , X=REAL(Z) C C WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND C RIGHT 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 ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0 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 CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS 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=REAL(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 TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) 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, REAL(Z) TOO C LARGE ON KODE=1 C IERR=3, CABS(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, CABS(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 CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(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) REAL(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.CABS(Z). C C IN MOST COMPLEX 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=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 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 COMPLEX 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(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(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 COMPLEX 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 COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, C PP 265-273. C C***ROUTINES CALLED ZBINU,ZABS,I1MACH,D1MACH C***END PROLOGUE ZBESI C COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN EXTERNAL ZABS DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH DIMENSION CYR(N), CYI(N) DATA PI /3.14159265358979324D0/ DATA CONER, CONEI /1.0D0,0.0D0/ C C***FIRST EXECUTABLE STATEMENT ZBESI IERR = 0 NZ=0 IF (FNU.LT.0.0D0) 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(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) C----------------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) FN = FNU+DBLE(FLOAT(N-1)) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(AA) IF (AZ.GT.AA) IERR=3 IF (FN.GT.AA) IERR=3 ZNR = ZR ZNI = ZI CSGNR = CONER CSGNI = CONEI IF (ZR.GE.0.0D0) GO TO 40 ZNR = -ZR ZNI = -ZI C----------------------------------------------------------------------- C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*PI IF (ZI.LT.0.0D0) ARG = -ARG CSGNR = DCOS(ARG) CSGNI = DSIN(ARG) IF (MOD(INU,2).EQ.0) GO TO 40 CSGNR = -CSGNR CSGNI = -CSGNI 40 CONTINUE CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) IF (NZ.LT.0) GO TO 120 IF (ZR.GE.0.0D0) RETURN C----------------------------------------------------------------------- C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE C----------------------------------------------------------------------- NN = N - NZ IF (NN.EQ.0) RETURN RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 50 I=1,NN C STR = CYR(I)*CSGNR - CYI(I)*CSGNI C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR C CYR(I) = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 55 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL CSGNR = -CSGNR CSGNI = -CSGNI 50 CONTINUE RETURN 120 CONTINUE IF(NZ.EQ.(-2)) GO TO 130 NZ = 0 IERR=2 RETURN 130 CONTINUE NZ=0 IERR=5 RETURN 260 CONTINUE NZ=0 IERR=4 RETURN END SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESJ C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801, 930101 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX 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 COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, ZBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESJ RETURNS THE SCALED C FUNCTIONS C C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(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 ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0 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,...,N C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS 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=AIMAG(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 ZERO DUE C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), 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, AIMAG(Z) C TOO LARGE ON KODE=1 C IERR=3, CABS(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, CABS(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) AIMAG(Z).GE.0.0 C C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(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.CABS(Z). C C IN MOST COMPLEX 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=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 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 COMPLEX 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(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(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 COMPLEX 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 COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, C PP 265-273. C C***ROUTINES CALLED ZBINU,ZABS,I1MACH,D1MACH C***END PROLOGUE ZBESJ C C COMPLEX CI,CSGN,CY,Z,ZN EXTERNAL ZABS DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH DIMENSION CYR(N), CYI(N) DATA HPI /1.57079632679489662D0/ C C***FIRST EXECUTABLE STATEMENT ZBESJ IERR = 0 NZ=0 IF (FNU.LT.0.0D0) 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(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) C----------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) FN = FNU+DBLE(FLOAT(N-1)) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(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----------------------------------------------------------------------- CII = 1.0D0 INU = INT(SNGL(FNU)) INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI CSGNR = DCOS(ARG) CSGNI = DSIN(ARG) IF (MOD(INUH,2).EQ.0) GO TO 40 CSGNR = -CSGNR CSGNI = -CSGNI 40 CONTINUE C----------------------------------------------------------------------- C ZN IS IN THE RIGHT HALF PLANE C----------------------------------------------------------------------- ZNR = ZI ZNI = -ZR IF (ZI.GE.0.0D0) GO TO 50 ZNR = -ZNR ZNI = -ZNI CSGNI = -CSGNI CII = -CII 50 CONTINUE CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) IF (NZ.LT.0) GO TO 130 NL = N - NZ IF (NL.EQ.0) RETURN RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 60 I=1,NL C STR = CYR(I)*CSGNR - CYI(I)*CSGNI C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR C CYR(I) = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 55 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL STR = -CSGNI*CII CSGNI = CSGNR*CII CSGNR = STR 60 CONTINUE RETURN 130 CONTINUE IF(NZ.EQ.(-2)) GO TO 140 NZ = 0 IERR = 2 RETURN 140 CONTINUE NZ=0 IERR=5 RETURN 260 CONTINUE NZ=0 IERR=4 RETURN END SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESK C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801, 930101 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS K-BESSEL FUNCTION,COMPLEX 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 COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C C ON KODE=1, ZBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0) C IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESK 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 ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), C -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0 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 CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS 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 DUE C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), 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 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 IS C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH C IERR=3, CABS(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, CABS(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 ZBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS C AVAILABLE. C C IN MOST COMPLEX 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=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 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 COMPLEX 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(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(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 COMPLEX 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 COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983. C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, C PP 265-273. C C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH C***END PROLOGUE ZBESK C C COMPLEX CY,Z EXTERNAL ZABS DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CYR(N), CYI(N) C***FIRST EXECUTABLE STATEMENT ZBESK IERR = 0 NZ=0 IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1 IF (FNU.LT.0.0D0) 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(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 C----------------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) FN = FNU + DBLE(FLOAT(NN-1)) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(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----------------------------------------------------------------------- C UFL = DEXP(-ELIM) UFL = D1MACH(1)*1.0D+3 IF (AZ.LT.UFL) GO TO 180 IF (FNU.GT.FNUL) GO TO 80 IF (FN.LE.1.0D0) GO TO 60 IF (FN.GT.2.0D0) GO TO 50 IF (AZ.GT.TOL) GO TO 60 ARG = 0.5D0*AZ ALN = -FN*DLOG(ARG) IF (ALN.GT.ELIM) GO TO 180 GO TO 60 50 CONTINUE CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, 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 (ZR.LT.0.0D0) GO TO 70 C----------------------------------------------------------------------- C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. C----------------------------------------------------------------------- CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, 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 (ZI.LT.0.0D0) MR = -1 CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, 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 (ZR.GE.0.0D0) GO TO 90 MR = 1 IF (ZI.LT.0.0D0) MR = -1 90 CONTINUE CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 200 NZ = NZ + NW RETURN 100 CONTINUE IF (ZR.LT.0.0D0) 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 260 CONTINUE NZ=0 IERR=4 RETURN END SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, * CWRKI, IERR) C***BEGIN PROLOGUE ZBESY C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801, 930101 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX 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 COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C C ON KODE=1, ZBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESY RETURNS THE SCALED C FUNCTIONS C C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(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 ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), C -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0 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=AIMAG(Z) C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT C CWRKI AT LEAST N C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS 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 IS C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH C IERR=3, CABS(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, CABS(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 IN TERMS OF THE I(FNU,Z) AND C K(FNU,Z) BESSEL FUNCTIONS IN THE RIGHT HALF PLANE BY C C Y(FNU,Z) = I*CC*I(FNU,ARG) - (2/PI)*CONJG(CC)*K(FNU,ARG) C C Y(FNU,Z) = CONJG(Y(FNU,CONJG(Z))) C C FOR AIMAG(Z).GE.0 AND AIMAG(Z).LT.0 RESPECTIVELY, WHERE C CC=EXP(I*PI*FNU/2), ARG=Z*EXP(-I*PI/2) AND I**2=-1. 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.CABS(Z). C C IN MOST COMPLEX 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=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 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 COMPLEX 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(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(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 COMPLEX 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 COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, C PP 265-273. C C***ROUTINES CALLED ZBESI,ZBESK,I1MACH,D1MACH C***END PROLOGUE ZBESY C C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV DOUBLE PRECISION ARG, ASCLE, CIPI, CIPR, CSGNI, CSGNR, CSPNI, * CSPNR, CWRKI, CWRKR, CYI, CYR, D1M5, D1MACH, ELIM, EXI, EXR, EY, * FNU, FFNU, HPI, RHPI, STR, STI, TAY, TOL, ATOL, RTOL, ZI, ZR, * ZNI, ZNR, ZUI, ZUR, ZVI, ZVR, ZZI, ZZR INTEGER I, IERR, IFNU, I4, K, KODE, K1, K2, N, NZ, NZ1, NZ2, * I1MACH DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N), CIPR(4), CIPI(4) DATA CIPR(1),CIPR(2),CIPR(3),CIPR(4)/1.0D0, 0.0D0, -1.0D0, 0.0D0/ DATA CIPI(1),CIPI(2),CIPI(3),CIPI(4)/0.0D0, 1.0D0, 0.0D0, -1.0D0/ DATA HPI / 1.57079632679489662D0 / C***FIRST EXECUTABLE STATEMENT ZBESY IERR = 0 NZ=0 IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 IF (FNU.LT.0.0D0) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (N.LT.1) IERR=1 IF (IERR.NE.0) RETURN ZZR = ZR ZZI = ZI IF (ZI.LT.0.0D0) ZZI = -ZZI ZNR = ZZI ZNI = -ZZR CALL ZBESI(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ1, IERR) IF (IERR.NE.0.AND.IERR.NE.3) GO TO 90 CALL ZBESK(ZNR, ZNI, FNU, KODE, N, CWRKR, CWRKI, NZ2, IERR) IF (IERR.NE.0.AND.IERR.NE.3) GO TO 90 NZ = MIN(NZ1,NZ2) IFNU = INT(SNGL(FNU)) FFNU = FNU - DBLE(FLOAT(IFNU)) ARG = HPI*FFNU CSGNR = COS(ARG) CSGNI = SIN(ARG) I4 = MOD(IFNU,4) + 1 STR = CSGNR*CIPR(I4) - CSGNI*CIPI(I4) CSGNI = CSGNR*CIPI(I4) + CSGNI*CIPR(I4) CSGNR = STR RHPI = 1.0D0/HPI CSPNR = CSGNR*RHPI CSPNI = -CSGNI*RHPI STR = -CSGNI CSGNI = CSGNR CSGNR = STR IF (KODE.EQ.2) GO TO 60 DO 50 I=1,N C CY(I) = CSGN*CY(I)-CSPN*CWRK(I) STR = CSGNR*CYR(I) - CSGNI*CYI(I) STR = STR - (CSPNR*CWRKR(I) - CSPNI*CWRKI(I)) STI = CSGNR*CYI(I) + CSGNI*CYR(I) STI = STI - (CSPNR*CWRKI(I) + CSPNI*CWRKR(I)) CYR(I) = STR CYI(I) = STI STR = - CSGNI CSGNI = CSGNR CSGNR = STR STR = CSPNI CSPNI = -CSPNR CSPNR = STR 50 CONTINUE IF (ZI.LT.0.0D0) THEN DO 55 I=1,N CYI(I) = -CYI(I) 55 CONTINUE ENDIF RETURN 60 CONTINUE EXR = COS(ZR) EXI = SIN(ZR) TOL = MAX(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) K = MIN(IABS(K1),IABS(K2)) D1M5 = D1MACH(5) C----------------------------------------------------------------------- C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT C----------------------------------------------------------------------- ELIM = 2.303D0*(DBLE(FLOAT(K))*D1M5-3.0D0) EY = 0.0D0 TAY = ABS(ZI+ZI) IF (TAY.LT.ELIM) EY = EXP(-TAY) STR = (EXR*CSPNR - EXI*CSPNI)*EY CSPNI = (EXR*CSPNI + EXI*CSPNR)*EY CSPNR = STR NZ = 0 RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 80 I=1,N C---------------------------------------------------------------------- C CY(I) = CSGN*CY(I)-CSPN*CWRK(I): PRODUCTS ARE COMPUTED IN C SCALED MODE IF CY(I) OR CWRK(I) ARE CLOSE TO UNDERFLOW TO C PREVENT UNDERFLOW IN AN INTERMEDIATE COMPUTATION. C---------------------------------------------------------------------- ZVR = CWRKR(I) ZVI = CWRKI(I) ATOL=1.0D0 IF (MAX(ABS(ZVR),ABS(ZVI)).GT.ASCLE) GO TO 75 ZVR = ZVR*RTOL ZVI = ZVI*RTOL ATOL = TOL 75 CONTINUE STR = (ZVR*CSPNR - ZVI*CSPNI)*ATOL ZVI = (ZVR*CSPNI + ZVI*CSPNR)*ATOL ZVR = STR ZUR = CYR(I) ZUI = CYI(I) ATOL=1.0D0 IF (MAX(ABS(ZUR),ABS(ZUI)).GT.ASCLE) GO TO 85 ZUR = ZUR*RTOL ZUI = ZUI*RTOL ATOL = TOL 85 CONTINUE STR = (ZUR*CSGNR - ZUI*CSGNI)*ATOL ZUI = (ZUR*CSGNI + ZUI*CSGNR)*ATOL ZUR = STR CYR(I) = ZUR - ZVR CYI(I) = ZUI - ZVI IF (ZI.LT.0.0D0) CYI(I) = -CYI(I) IF (CYR(I).EQ.0.0D0 .AND. CYI(I).EQ.0.0D0 .AND. EY.EQ.0.0D0) & NZ = NZ + 1 STR = -CSGNI CSGNI = CSGNR CSGNR = STR STR = CSPNI CSPNI = -CSPNR CSPNR = STR 80 CONTINUE RETURN 90 CONTINUE NZ = 0 RETURN END SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) C***BEGIN PROLOGUE ZAIRY C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801, 930101 (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 COMPLEX Z C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, ZAIRY COMPUTES THE COMPLEX 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 CEXP(ZTA)*AI(Z) OR CEXP(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*CSQRT(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 REAL AXIS. C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF C MATHEMATICAL FUNCTIONS (REF. 1). C C INPUT ZR,ZI ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI) 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=CEXP(ZTA)*AI(Z) ON ID=0 OR C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE C ZTA=(2/3)*Z*CSQRT(Z) C C OUTPUT AIR,AII ARE DOUBLE PRECISION C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND C KODE C NZ - UNDERFLOW INDICATOR C NZ= 0 , NORMAL RETURN C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) 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, REAL(ZTA) C TOO LARGE ON KODE=1 C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION C PRODUCE LESS THAN HALF OF MACHINE ACCURACY C IERR=4, CABS(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 AI AND DAI ARE COMPUTED FOR CABS(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 CABS(Z).LE.1.0. C C IN MOST COMPLEX 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=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 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 COMPLEX 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(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(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 COMPLEX 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 COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, C PP 265-273. C C***ROUTINES CALLED ZACAI,ZBKNU,ZEXP,ZSQRT,ZABS,I1MACH,D1MACH C***END PROLOGUE ZAIRY C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 EXTERNAL ZABS DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH DIMENSION CYR(1), CYI(1) DATA TTH, C1, C2, COEF /6.66666666666666667D-01, * 3.55028053887817240D-01,2.58819403792806799D-01, * 1.83776298473930683D-01/ DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ C***FIRST EXECUTABLE STATEMENT ZAIRY 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(ZR,ZI) TOL = DMAX1(D1MACH(4),1.0D-18) FID = DBLE(FLOAT(ID)) IF (AZ.GT.1.0D0) GO TO 70 C----------------------------------------------------------------------- C POWER SERIES FOR CABS(Z).LE.1. C----------------------------------------------------------------------- S1R = CONER S1I = CONEI S2R = CONER S2I = CONEI IF (AZ.LT.TOL) GO TO 170 AA = AZ*AZ IF (AA.LT.TOL/AZ) GO TO 40 TRM1R = CONER TRM1I = CONEI TRM2R = CONER TRM2I = CONEI ATRM = 1.0D0 STR = ZR*ZR - ZI*ZI STI = ZR*ZI + ZI*ZR Z3R = STR*ZR - STI*ZI Z3I = STR*ZI + STI*ZR AZ3 = AZ*AA AK = 2.0D0 + FID BK = 3.0D0 - FID - FID CK = 4.0D0 - FID DK = 3.0D0 + FID + FID D1 = AK*DK D2 = BK*CK AD = DMIN1(D1,D2) AK = 24.0D0 + 9.0D0*FID BK = 30.0D0 - 9.0D0*FID DO 30 K=1,25 STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 TRM1R = STR S1R = S1R + TRM1R S1I = S1I + TRM1I STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 TRM2R = STR S2R = S2R + TRM2R S2I = S2I + TRM2I 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.0D0 BK = BK + 18.0D0 30 CONTINUE 40 CONTINUE IF (ID.EQ.1) GO TO 50 AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I) AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R) IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) CALL ZEXP(ZTAR, ZTAI, STR, STI) PTR = AIR*STR - AII*STI AII = AIR*STI + AII*STR AIR = PTR RETURN 50 CONTINUE AIR = -S2R*C2 AII = -S2I*C2 IF (AZ.LE.TOL) GO TO 60 STR = ZR*S1R - ZI*S1I STI = ZR*S1I + ZI*S1R CC = C1/(1.0D0+FID) AIR = AIR + CC*(STR*ZR-STI*ZI) AII = AII + CC*(STR*ZI+STI*ZR) 60 CONTINUE IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) CALL ZEXP(ZTAR, ZTAI, STR, STI) PTR = STR*AIR - STI*AII AII = STR*AII + STI*AIR AIR = PTR RETURN C----------------------------------------------------------------------- C CASE FOR CABS(Z).GT.1.0 C----------------------------------------------------------------------- 70 CONTINUE FNU = (1.0D0+FID)/3.0D0 C----------------------------------------------------------------------- C SET PARAMETERS RELATED TO MACHINE CONSTANTS. C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-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(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 ALAZ = DLOG(AZ) C-------------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AA=0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA=DMIN1(AA,BB) AA=AA**TTH IF (AZ.GT.AA) GO TO 260 AA=DSQRT(AA) IF (AZ.GT.AA) IERR=3 CALL ZSQRT(ZR, ZI, CSQR, CSQI) ZTAR = TTH*(ZR*CSQR-ZI*CSQI) ZTAI = TTH*(ZR*CSQI+ZI*CSQR) C----------------------------------------------------------------------- C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL C----------------------------------------------------------------------- IFLAG = 0 SFAC = 1.0D0 AK = ZTAI IF (ZR.GE.0.0D0) GO TO 80 BK = ZTAR CK = -DABS(BK) ZTAR = CK ZTAI = AK 80 CONTINUE IF (ZI.NE.0.0D0) GO TO 90 IF (ZR.GT.0.0D0) GO TO 90 ZTAR = 0.0D0 ZTAI = AK 90 CONTINUE AA = ZTAR IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 IF (KODE.EQ.2) GO TO 100 C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- IF (AA.GT.(-ALIM)) GO TO 100 AA = -AA + 0.25D0*ALAZ IFLAG = 1 SFAC = TOL IF (AA.GT.ELIM) GO TO 270 100 CONTINUE C----------------------------------------------------------------------- C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 C----------------------------------------------------------------------- MR = 1 IF (ZI.LT.0.0D0) MR = -1 CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, * ELIM, ALIM) IF (NN.LT.0) GO TO 280 NZ = NZ + NN GO TO 130 110 CONTINUE IF (KODE.EQ.2) GO TO 120 C----------------------------------------------------------------------- C UNDERFLOW TEST C----------------------------------------------------------------------- IF (AA.LT.ALIM) GO TO 120 AA = -AA - 0.25D0*ALAZ IFLAG = 2 SFAC = 1.0D0/TOL IF (AA.LT.(-ELIM)) GO TO 210 120 CONTINUE CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, * ALIM) 130 CONTINUE S1R = CYR(1)*COEF S1I = CYI(1)*COEF IF (IFLAG.NE.0) GO TO 150 IF (ID.EQ.1) GO TO 140 AIR = CSQR*S1R - CSQI*S1I AII = CSQR*S1I + CSQI*S1R RETURN 140 CONTINUE AIR = -(ZR*S1R-ZI*S1I) AII = -(ZR*S1I+ZI*S1R) RETURN 150 CONTINUE S1R = S1R*SFAC S1I = S1I*SFAC IF (ID.EQ.1) GO TO 160 STR = S1R*CSQR - S1I*CSQI S1I = S1R*CSQI + S1I*CSQR S1R = STR AIR = S1R/SFAC AII = S1I/SFAC RETURN 160 CONTINUE STR = -(S1R*ZR-S1I*ZI) S1I = -(S1R*ZI+S1I*ZR) S1R = STR AIR = S1R/SFAC AII = S1I/SFAC RETURN 170 CONTINUE AA = 1.0D+3*D1MACH(1) S1R = ZEROR S1I = ZEROI IF (ID.EQ.1) GO TO 190 IF (AZ.LE.AA) GO TO 180 S1R = C2*ZR S1I = C2*ZI 180 CONTINUE AIR = C1 - S1R AII = -S1I RETURN 190 CONTINUE AIR = -C2 AII = 0.0D0 AA = DSQRT(AA) IF (AZ.LE.AA) GO TO 200 S1R = 0.5D0*(ZR*ZR-ZI*ZI) S1I = ZR*ZI 200 CONTINUE AIR = AIR + C1*S1R AII = AII + C1*S1I RETURN 210 CONTINUE NZ = 1 AIR = ZEROR AII = ZEROI RETURN 270 CONTINUE NZ = 0 IERR=2 RETURN 280 CONTINUE IF(NN.EQ.(-1)) GO TO 270 NZ=0 IERR=5 RETURN 260 CONTINUE IERR=4 NZ=0 RETURN END SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR) C***BEGIN PROLOGUE ZBIRY C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801, 930101 (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 COMPLEX Z C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, CBIRY COMPUTES THE COMPLEX 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 CEXP(-AXZTA)*BI(Z) OR CEXP(-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*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA). C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF C MATHEMATICAL FUNCTIONS (REF. 1). C C INPUT ZR,ZI ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI) 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=CEXP(-AXZTA)*BI(Z) ON ID=0 OR C BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) C AND AXZTA=ABS(XZTA) C C OUTPUT BIR,BII ARE DOUBLE PRECISION C BIR,BII- COMPLEX 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, REAL(Z) C TOO LARGE ON KODE=1 C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION C PRODUCE LESS THAN HALF OF MACHINE ACCURACY C IERR=4, CABS(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 CABS(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 CABS(Z).LE.1.0. C C IN MOST COMPLEX 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=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 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 COMPLEX 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(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(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 COMPLEX 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 COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, C PP 265-273. C C***ROUTINES CALLED ZBINU,ZABS,ZDIV,ZSQRT,D1MACH,I1MACH C***END PROLOGUE ZBIRY C COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 EXTERNAL ZABS DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR, * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH DIMENSION CYR(2), CYI(2) DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01, * 6.14926627446000736D-01,4.48288357353826359D-01, * 5.77350269189625765D-01,3.14159265358979324D+00/ DATA CONER, CONEI /1.0D0,0.0D0/ C***FIRST EXECUTABLE STATEMENT ZBIRY 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(ZR,ZI) TOL = DMAX1(D1MACH(4),1.0D-18) FID = DBLE(FLOAT(ID)) IF (AZ.GT.1.0E0) GO TO 70 C----------------------------------------------------------------------- C POWER SERIES FOR CABS(Z).LE.1. C----------------------------------------------------------------------- S1R = CONER S1I = CONEI S2R = CONER S2I = CONEI IF (AZ.LT.TOL) GO TO 130 AA = AZ*AZ IF (AA.LT.TOL/AZ) GO TO 40 TRM1R = CONER TRM1I = CONEI TRM2R = CONER TRM2I = CONEI ATRM = 1.0D0 STR = ZR*ZR - ZI*ZI STI = ZR*ZI + ZI*ZR Z3R = STR*ZR - STI*ZI Z3I = STR*ZI + STI*ZR AZ3 = AZ*AA AK = 2.0D0 + FID BK = 3.0D0 - FID - FID CK = 4.0D0 - FID DK = 3.0D0 + FID + FID D1 = AK*DK D2 = BK*CK AD = DMIN1(D1,D2) AK = 24.0D0 + 9.0D0*FID BK = 30.0D0 - 9.0D0*FID DO 30 K=1,25 STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 TRM1R = STR S1R = S1R + TRM1R S1I = S1I + TRM1I STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 TRM2R = STR S2R = S2R + TRM2R S2I = S2I + TRM2I 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.0D0 BK = BK + 18.0D0 30 CONTINUE 40 CONTINUE IF (ID.EQ.1) GO TO 50 BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I) BII = C1*S1I + C2*(ZR*S2I+ZI*S2R) IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) AA = ZTAR AA = -DABS(AA) EAA = DEXP(AA) BIR = BIR*EAA BII = BII*EAA RETURN 50 CONTINUE BIR = S2R*C2 BII = S2I*C2 IF (AZ.LE.TOL) GO TO 60 CC = C1/(1.0D0+FID) STR = S1R*ZR - S1I*ZI STI = S1R*ZI + S1I*ZR BIR = BIR + CC*(STR*ZR-STI*ZI) BII = BII + CC*(STR*ZI+STI*ZR) 60 CONTINUE IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) AA = ZTAR AA = -DABS(AA) EAA = DEXP(AA) BIR = BIR*EAA BII = BII*EAA RETURN C----------------------------------------------------------------------- C CASE FOR CABS(Z).GT.1.0 C----------------------------------------------------------------------- 70 CONTINUE FNU = (1.0D0+FID)/3.0D0 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(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) C----------------------------------------------------------------------- C TEST FOR RANGE C----------------------------------------------------------------------- AA=0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA=DMIN1(AA,BB) AA=AA**TTH IF (AZ.GT.AA) GO TO 260 AA=DSQRT(AA) IF (AZ.GT.AA) IERR=3 CALL ZSQRT(ZR, ZI, CSQR, CSQI) ZTAR = TTH*(ZR*CSQR-ZI*CSQI) ZTAI = TTH*(ZR*CSQI+ZI*CSQR) C----------------------------------------------------------------------- C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL C----------------------------------------------------------------------- SFAC = 1.0D0 AK = ZTAI IF (ZR.GE.0.0D0) GO TO 80 BK = ZTAR CK = -DABS(BK) ZTAR = CK ZTAI = AK 80 CONTINUE IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90 ZTAR = 0.0D0 ZTAI = AK 90 CONTINUE AA = ZTAR IF (KODE.EQ.2) GO TO 100 C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- BB = DABS(AA) IF (BB.LT.ALIM) GO TO 100 BB = BB + 0.25D0*DLOG(AZ) SFAC = TOL IF (BB.GT.ELIM) GO TO 190 100 CONTINUE FMR = 0.0D0 IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 FMR = PI IF (ZI.LT.0.0D0) FMR = -PI ZTAR = -ZTAR ZTAI = -ZTAI 110 CONTINUE C----------------------------------------------------------------------- C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM ZBESI C----------------------------------------------------------------------- CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) IF (NZ.LT.0) GO TO 200 AA = FMR*FNU Z3R = SFAC STR = DCOS(AA) STI = DSIN(AA) S1R = (STR*CYR(1)-STI*CYI(1))*Z3R S1I = (STR*CYI(1)+STI*CYR(1))*Z3R FNU = (2.0D0-FID)/3.0D0 CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) CYR(1) = CYR(1)*Z3R CYI(1) = CYI(1)*Z3R CYR(2) = CYR(2)*Z3R CYI(2) = CYI(2)*Z3R C----------------------------------------------------------------------- C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 C----------------------------------------------------------------------- CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI) S2R = (FNU+FNU)*STR + CYR(2) S2I = (FNU+FNU)*STI + CYI(2) AA = FMR*(FNU-1.0D0) STR = DCOS(AA) STI = DSIN(AA) S1R = COEF*(S1R+S2R*STR-S2I*STI) S1I = COEF*(S1I+S2R*STI+S2I*STR) IF (ID.EQ.1) GO TO 120 STR = CSQR*S1R - CSQI*S1I S1I = CSQR*S1I + CSQI*S1R S1R = STR BIR = S1R/SFAC BII = S1I/SFAC RETURN 120 CONTINUE STR = ZR*S1R - ZI*S1I S1I = ZR*S1I + ZI*S1R S1R = STR BIR = S1R/SFAC BII = S1I/SFAC RETURN 130 CONTINUE AA = C1*(1.0D0-FID) + FID*C2 BIR = AA BII = 0.0D0 RETURN 190 CONTINUE IERR=2 NZ=0 RETURN 200 CONTINUE IF(NZ.EQ.(-1)) GO TO 190 NZ=0 IERR=5 RETURN 260 CONTINUE IERR=4 NZ=0 RETURN END SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI) C***BEGIN PROLOGUE ZMLT C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZMLT DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB CA = AR*BR - AI*BI CB = AR*BI + AI*BR CR = CA CI = CB RETURN END SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI) C***BEGIN PROLOGUE ZDIV C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. C C***ROUTINES CALLED ZABS C***END PROLOGUE ZDIV EXTERNAL ZABS DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD DOUBLE PRECISION ZABS BM = 1.0D0/ZABS(BR,BI) CC = BR*BM CD = BI*BM CA = (AR*CC+AI*CD)*BM CB = (AI*CC-AR*CD)*BM CR = CA CI = CB RETURN END SUBROUTINE ZSQRT(AR, AI, BR, BI) C***BEGIN PROLOGUE ZSQRT C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) C C***ROUTINES CALLED ZABS C***END PROLOGUE ZSQRT EXTERNAL ZABS DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT DOUBLE PRECISION ZABS DATA DRT , DPI / 7.071067811865475244008443621D-1, 1 3.141592653589793238462643383D+0/ ZM = ZABS(AR,AI) ZM = DSQRT(ZM) IF (AR.EQ.0.0D+0) GO TO 10 IF (AI.EQ.0.0D+0) GO TO 20 DTHETA = DATAN(AI/AR) IF (DTHETA.LE.0.0D+0) GO TO 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI GO TO 50 10 IF (AI.GT.0.0D+0) GO TO 60 IF (AI.LT.0.0D+0) GO TO 70 BR = 0.0D+0 BI = 0.0D+0 RETURN 20 IF (AR.GT.0.0D+0) GO TO 30 BR = 0.0D+0 BI = DSQRT(DABS(AR)) RETURN 30 BR = DSQRT(AR) BI = 0.0D+0 RETURN 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI 50 DTHETA = DTHETA*0.5D+0 BR = ZM*DCOS(DTHETA) BI = ZM*DSIN(DTHETA) RETURN 60 BR = ZM*DRT BI = ZM*DRT RETURN 70 BR = ZM*DRT BI = -ZM*DRT RETURN END SUBROUTINE ZEXP(AR, AI, BR, BI) C***BEGIN PROLOGUE ZEXP C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZEXP DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB ZM = DEXP(AR) CA = ZM*DCOS(AI) CB = ZM*DSIN(AI) BR = CA BI = CB RETURN END SUBROUTINE ZLOG(AR, AI, BR, BI, IERR) C***BEGIN PROLOGUE ZLOG C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) C***ROUTINES CALLED ZABS C***END PROLOGUE ZLOG EXTERNAL ZABS DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI DOUBLE PRECISION ZABS INTEGER IERR DATA DPI , DHPI / 3.141592653589793238462643383D+0, 1 1.570796326794896619231321696D+0/ C IERR=0 IF (AR.EQ.0.0D+0) GO TO 10 IF (AI.EQ.0.0D+0) GO TO 20 DTHETA = DATAN(AI/AR) IF (DTHETA.LE.0.0D+0) GO TO 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI GO TO 50 10 IF (AI.EQ.0.0D+0) GO TO 60 BI = DHPI BR = DLOG(DABS(AI)) IF (AI.LT.0.0D+0) BI = -BI RETURN 20 IF (AR.GT.0.0D+0) GO TO 30 BR = DLOG(DABS(AR)) BI = DPI RETURN 30 BR = DLOG(AR) BI = 0.0D+0 RETURN 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI 50 ZM = ZABS(AR,AI) BR = DLOG(ZM) BI = DTHETA RETURN 60 CONTINUE IERR=1 RETURN END DOUBLE PRECISION FUNCTION ZABS(ZR, ZI) C***BEGIN PROLOGUE ZABS C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZABS DOUBLE PRECISION ZR, ZI, U, V, Q, S U = DABS(ZR) V = DABS(ZI) S = U + V C----------------------------------------------------------------------- C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A C TRUE FLOATING ZERO C----------------------------------------------------------------------- S = S*1.0D+0 IF (S.EQ.0.0D+0) GO TO 20 IF (U.GT.V) GO TO 10 Q = U/V ZABS = V*DSQRT(1.D+0+Q*Q) RETURN 10 Q = V/U ZABS = U*DSQRT(1.D+0+Q*Q) RETURN 20 ZABS = 0.0D+0 RETURN END SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZBKNU C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH C C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. C C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV, C ZEXP,ZLOG,ZMLT,ZSQRT C***END PROLOGUE ZBKNU C EXTERNAL ZABS DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, * IDUM, I1MACH, J, IC, INUB, NW DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), * CYI(2) C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK C DATA KMAX / 30 / DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ 1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / 1 3.14159265358979324D0, 1.25331413731550025D0, 2 1.90985931710274403D0, 1.57079632679489662D0, 3 1.89769999331517738D0, 6.66666666666666666D-01/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ 1 5.77215664901532861D-01, -4.20026350340952355D-02, 2 -4.21977345555443367D-02, 7.21894324666309954D-03, 3 -2.15241674114950973D-04, -2.01348547807882387D-05, 4 1.13302723198169588D-06, 6.11609510448141582D-09/ C CAZ = ZABS(ZR,ZI) CSCLR = 1.0D0/TOL CRSCR = TOL CSSR(1) = CSCLR CSSR(2) = 1.0D0 CSSR(3) = CRSCR CSRR(1) = CRSCR CSRR(2) = 1.0D0 CSRR(3) = CSCLR BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) NZ = 0 IFLAG = 0 KODED = KODE RCAZ = 1.0D0/CAZ STR = ZR*RCAZ STI = -ZI*RCAZ RZR = (STR+STR)*RCAZ RZI = (STI+STI)*RCAZ INU = INT(FNU+0.5D0) DNU = FNU - DBLE(FLOAT(INU)) IF (DABS(DNU).EQ.0.5D0) GO TO 110 DNU2 = 0.0D0 IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU IF (CAZ.GT.R1) GO TO 110 C----------------------------------------------------------------------- C SERIES FOR CABS(Z).LE.R1 C----------------------------------------------------------------------- FC = 1.0D0 CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM) FMUR = SMUR*DNU FMUI = SMUI*DNU CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI) IF (DNU.EQ.0.0D0) GO TO 10 FC = DNU*DPI FC = FC/DSIN(FC) SMUR = CSHR/DNU SMUI = CSHI/DNU 10 CONTINUE A2 = 1.0D0 + 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 = DEXP(-DGAMLN(A2,IDUM)) T1 = 1.0D0/(T2*FC) IF (DABS(DNU).GT.0.1D0) GO TO 40 C----------------------------------------------------------------------- C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) C----------------------------------------------------------------------- AK = 1.0D0 S = CC(1) DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM IF (DABS(TM).LT.TOL) GO TO 30 20 CONTINUE 30 G1 = -S GO TO 50 40 CONTINUE G1 = (T1-T2)/(DNU+DNU) 50 CONTINUE G2 = (T1+T2)*0.5D0 FR = FC*(CCHR*G1+SMUR*G2) FI = FC*(CCHI*G1+SMUI*G2) CALL ZEXP(FMUR, FMUI, STR, STI) PR = 0.5D0*STR/T2 PI = 0.5D0*STI/T2 CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI) QR = PTR/T1 QI = PTI/T1 S1R = FR S1I = FI S2R = PR S2I = PI AK = 1.0D0 A1 = 1.0D0 CKR = CONER CKI = CONEI BK = 1.0D0 - 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 CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) CZR = 0.25D0*CZR CZI = 0.25D0*CZI T1 = 0.25D0*CAZ*CAZ 60 CONTINUE FR = (FR*AK+PR+QR)/BK FI = (FI*AK+PI+QI)/BK STR = 1.0D0/(AK-DNU) PR = PR*STR PI = PI*STR STR = 1.0D0/(AK+DNU) QR = QR*STR QI = QI*STR STR = CKR*CZR - CKI*CZI RAK = 1.0D0/AK CKI = (CKR*CZI+CKI*CZR)*RAK CKR = STR*RAK S1R = CKR*FR - CKI*FI + S1R S1I = CKR*FI + CKI*FR + S1I A1 = A1*T1*RAK BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 IF (A1.GT.TOL) GO TO 60 70 CONTINUE YR(1) = S1R YI(1) = S1I IF (KODED.EQ.1) RETURN CALL ZEXP(ZR, ZI, STR, STI) CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1)) 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 CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) CZR = 0.25D0*CZR CZI = 0.25D0*CZI T1 = 0.25D0*CAZ*CAZ 90 CONTINUE FR = (FR*AK+PR+QR)/BK FI = (FI*AK+PI+QI)/BK STR = 1.0D0/(AK-DNU) PR = PR*STR PI = PI*STR STR = 1.0D0/(AK+DNU) QR = QR*STR QI = QI*STR STR = CKR*CZR - CKI*CZI RAK = 1.0D0/AK CKI = (CKR*CZI+CKI*CZR)*RAK CKR = STR*RAK S1R = CKR*FR - CKI*FI + S1R S1I = CKR*FI + CKI*FR + S1I STR = PR - FR*AK STI = PI - FI*AK S2R = CKR*STR - CKI*STI + S2R S2I = CKR*STI + CKI*STR + S2I A1 = A1*T1*RAK BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 IF (A1.GT.TOL) GO TO 90 100 CONTINUE KFLAG = 2 A1 = FNU + 1.0D0 AK = A1*DABS(SMUR) IF (AK.GT.ALIM) KFLAG = 3 STR = CSSR(KFLAG) P2R = S2R*STR P2I = S2I*STR CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I) S1R = S1R*STR S1I = S1I*STR IF (KODED.EQ.1) GO TO 210 CALL ZEXP(ZR, ZI, FR, FI) CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I) CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I) 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 CALL ZSQRT(ZR, ZI, STR, STI) CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI) KFLAG = 2 IF (KODED.EQ.2) GO TO 120 IF (ZR.GT.ALIM) GO TO 290 C BLANK LINE STR = DEXP(-ZR)*CSSR(KFLAG) STI = -STR*DSIN(ZI) STR = STR*DCOS(ZI) CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI) 120 CONTINUE IF (DABS(DNU).EQ.0.5D0) GO TO 300 C----------------------------------------------------------------------- C MILLER ALGORITHM FOR CABS(Z).GT.R1 C----------------------------------------------------------------------- AK = DCOS(DPI*DNU) AK = DABS(AK) IF (AK.EQ.CZEROR) GO TO 300 FHS = DABS(0.25D0-DNU2) IF (FHS.EQ.CZEROR) GO TO 300 C----------------------------------------------------------------------- C COMPUTE R2=F(E). IF CABS(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(14))= C TOL WHERE B IS THE BASE OF THE ARITHMETIC. C----------------------------------------------------------------------- T1 = DBLE(FLOAT(I1MACH(14)-1)) T1 = T1*D1MACH(5)*3.321928094D0 T1 = DMAX1(T1,12.0D0) T1 = DMIN1(T1,60.0D0) T2 = TTH*T1 - 6.0D0 IF (ZR.NE.0.0D0) GO TO 130 T1 = HPI GO TO 140 130 CONTINUE T1 = DATAN(ZI/ZR) T1 = DABS(T1) 140 CONTINUE IF (T2.GT.CAZ) GO TO 170 C----------------------------------------------------------------------- C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 C----------------------------------------------------------------------- ETEST = AK/(DPI*CAZ*TOL) FK = CONER IF (ETEST.LT.CONER) GO TO 180 FKS = CTWOR CKR = CAZ + CAZ + CTWOR P1R = CZEROR P2R = CONER DO 150 I=1,KMAX AK = FHS/FKS CBR = CKR/(FK+CONER) PTR = P2R P2R = CBR*P2R - P1R*AK P1R = PTR CKR = CKR + CTWOR FKS = FKS + FK + FK + CTWOR FHS = FHS + FK + FK FK = FK + CONER STR = DABS(P2R)*FK IF (ETEST.LT.STR) GO TO 160 150 CONTINUE GO TO 310 160 CONTINUE FK = FK + SPI*T1*DSQRT(T2/CAZ) FHS = DABS(0.25D0-DNU2) GO TO 180 170 CONTINUE C----------------------------------------------------------------------- C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 C----------------------------------------------------------------------- A2 = DSQRT(CAZ) AK = FPI*AK/(TOL*DSQRT(A2)) AA = 3.0D0*T1/(1.0D0+CAZ) BB = 14.7D0*T1/(28.0D0+CAZ) AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB) FK = 0.12125D0*AK*AK/CAZ + 1.5D0 180 CONTINUE C----------------------------------------------------------------------- C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM C----------------------------------------------------------------------- K = INT(SNGL(FK)) FK = DBLE(FLOAT(K)) FKS = FK*FK P1R = CZEROR P1I = CZEROI P2R = TOL P2I = CZEROI CSR = P2R CSI = P2I DO 190 I=1,K A1 = FKS - FK AK = (FKS+FK)/(A1+FHS) RAK = 2.0D0/(FK+CONER) CBR = (FK+ZR)*RAK CBI = ZI*RAK PTR = P2R PTI = P2I P2R = (PTR*CBR-PTI*CBI-P1R)*AK P2I = (PTI*CBR+PTR*CBI-P1I)*AK P1R = PTR P1I = PTI CSR = CSR + P2R CSI = CSI + P2I FKS = A1 - FK + CONER FK = FK - CONER 190 CONTINUE C----------------------------------------------------------------------- C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER C SCALING C----------------------------------------------------------------------- TM = ZABS(CSR,CSI) PTR = 1.0D0/TM S1R = P2R*PTR S1I = P2I*PTR CSR = CSR*PTR CSI = -CSI*PTR CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI) CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I) IF (INU.GT.0 .OR. N.GT.1) GO TO 200 ZDR = ZR ZDI = ZI IF(IFLAG.EQ.1) GO TO 270 GO TO 240 200 CONTINUE C----------------------------------------------------------------------- C COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING C----------------------------------------------------------------------- TM = ZABS(P2R,P2I) PTR = 1.0D0/TM P1R = P1R*PTR P1I = P1I*PTR P2R = P2R*PTR P2I = -P2I*PTR CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI) STR = DNU + 0.5D0 - PTR STI = -PTI CALL ZDIV(STR, STI, ZR, ZI, STR, STI) STR = STR + 1.0D0 CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I) C----------------------------------------------------------------------- C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 C----------------------------------------------------------------------- 210 CONTINUE STR = DNU + 1.0D0 CKR = STR*RZR CKI = STR*RZI IF (N.EQ.1) INU = INU - 1 IF (INU.GT.0) GO TO 220 IF (N.GT.1) GO TO 215 S1R = S2R S1I = S2I 215 CONTINUE ZDR = ZR ZDI = ZI IF(IFLAG.EQ.1) GO TO 270 GO TO 240 220 CONTINUE INUB = 1 IF(IFLAG.EQ.1) GO TO 261 225 CONTINUE P1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 230 I=INUB,INU STR = S2R STI = S2I S2R = CKR*STR - CKI*STI + S1R S2I = CKR*STI + CKI*STR + S1I S1R = STR S1I = STI CKR = CKR + RZR CKI = CKI + RZI IF (KFLAG.GE.3) GO TO 230 P2R = S2R*P1R P2I = S2I*P1R STR = DABS(P2R) STI = DABS(P2I) P2M = DMAX1(STR,STI) IF (P2M.LE.ASCLE) GO TO 230 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*P1R S1I = S1I*P1R S2R = P2R S2I = P2I STR = CSSR(KFLAG) S1R = S1R*STR S1I = S1I*STR S2R = S2R*STR S2I = S2I*STR P1R = CSRR(KFLAG) 230 CONTINUE IF (N.NE.1) GO TO 240 S1R = S2R S1I = S2I 240 CONTINUE STR = CSRR(KFLAG) YR(1) = S1R*STR YI(1) = S1I*STR IF (N.EQ.1) RETURN YR(2) = S2R*STR YI(2) = S2I*STR IF (N.EQ.2) RETURN KK = 2 250 CONTINUE KK = KK + 1 IF (KK.GT.N) RETURN P1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 260 I=KK,N P2R = S2R P2I = S2I S2R = CKR*P2R - CKI*P2I + S1R S2I = CKI*P2R + CKR*P2I + S1I S1R = P2R S1I = P2I CKR = CKR + RZR CKI = CKI + RZI P2R = S2R*P1R P2I = S2I*P1R YR(I) = P2R YI(I) = P2I IF (KFLAG.GE.3) GO TO 260 STR = DABS(P2R) STI = DABS(P2I) P2M = DMAX1(STR,STI) IF (P2M.LE.ASCLE) GO TO 260 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*P1R S1I = S1I*P1R S2R = P2R S2I = P2I STR = CSSR(KFLAG) S1R = S1R*STR S1I = S1I*STR S2R = S2R*STR S2I = S2I*STR P1R = CSRR(KFLAG) 260 CONTINUE RETURN C----------------------------------------------------------------------- C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW C----------------------------------------------------------------------- 261 CONTINUE HELIM = 0.5D0*ELIM ELM = DEXP(-ELIM) CELMR = ELM ASCLE = BRY(1) ZDR = ZR ZDI = ZI IC = -1 J = 2 DO 262 I=1,INU STR = S2R STI = S2I S2R = STR*CKR-STI*CKI+S1R S2I = STI*CKR+STR*CKI+S1I S1R = STR S1I = STI CKR = CKR+RZR CKI = CKI+RZI AS = ZABS(S2R,S2I) ALAS = DLOG(AS) P2R = -ZDR+ALAS IF(P2R.LT.(-ELIM)) GO TO 263 CALL ZLOG(S2R,S2I,STR,STI,IDUM) P2R = -ZDR+STR P2I = -ZDI+STI P2M = DEXP(P2R)/TOL P1R = P2M*DCOS(P2I) P1I = P2M*DSIN(P2I) CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL) IF(NW.NE.0) GO TO 263 J = 3 - J CYR(J) = P1R CYI(J) = P1I IF(IC.EQ.(I-1)) GO TO 264 IC = I GO TO 262 263 CONTINUE IF(ALAS.LT.HELIM) GO TO 262 ZDR = ZDR-ELIM S1R = S1R*CELMR S1I = S1I*CELMR S2R = S2R*CELMR S2I = S2I*CELMR 262 CONTINUE IF(N.NE.1) GO TO 270 S1R = S2R S1I = S2I GO TO 270 264 CONTINUE KFLAG = 1 INUB = I+1 S2R = CYR(J) S2I = CYI(J) J = 3 - J S1R = CYR(J) S1I = CYI(J) IF(INUB.LE.INU) GO TO 225 IF(N.NE.1) GO TO 240 S1R = S2R S1I = S2I GO TO 240 270 CONTINUE YR(1) = S1R YI(1) = S1I IF(N.EQ.1) GO TO 280 YR(2) = S2R YI(2) = S2I 280 CONTINUE ASCLE = BRY(1) CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) INU = N - NZ IF (INU.LE.0) RETURN KK = NZ + 1 S1R = YR(KK) S1I = YI(KK) YR(KK) = S1R*CSRR(1) YI(KK) = S1I*CSRR(1) IF (INU.EQ.1) RETURN KK = NZ + 2 S2R = YR(KK) S2I = YI(KK) YR(KK) = S2R*CSRR(1) YI(KK) = S2I*CSRR(1) IF (INU.EQ.2) RETURN T2 = FNU + DBLE(FLOAT(KK-1)) CKR = T2*RZR CKI = T2*RZI KFLAG = 1 GO TO 250 290 CONTINUE C----------------------------------------------------------------------- C SCALE BY DEXP(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 S1R = COEFR S1I = COEFI S2R = COEFR S2I = COEFI GO TO 210 C C 310 CONTINUE NZ=-2 RETURN END SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) C***BEGIN PROLOGUE ZKSCL C***REFER TO ZBESK 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 ZUCHK,ZABS,ZLOG C***END PROLOGUE ZKSCL C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM EXTERNAL ZABS DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, * ZDR, ZDI, CELMR, ELM, HELIM, ALAS INTEGER I, IC, IDUM, KK, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2) DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / C NZ = 0 IC = 0 NN = MIN0(2,N) DO 10 I=1,NN S1R = YR(I) S1I = YI(I) CYR(I) = S1R CYI(I) = S1I AS = ZABS(S1R,S1I) ACS = -ZRR + DLOG(AS) NZ = NZ + 1 YR(I) = ZEROR YI(I) = ZEROI IF (ACS.LT.(-ELIM)) GO TO 10 CALL ZLOG(S1R, S1I, CSR, CSI, IDUM) CSR = CSR - ZRR CSI = CSI - ZRI STR = DEXP(CSR)/TOL CSR = STR*DCOS(CSI) CSI = STR*DSIN(CSI) CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 10 YR(I) = CSR YI(I) = CSI IC = I NZ = NZ - 1 10 CONTINUE IF (N.EQ.1) RETURN IF (IC.GT.1) GO TO 20 YR(1) = ZEROR YI(1) = ZEROI NZ = 2 20 CONTINUE IF (N.EQ.2) RETURN IF (NZ.EQ.0) RETURN FN = FNU + 1.0D0 CKR = FN*RZR CKI = FN*RZI S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) HELIM = 0.5D0*ELIM ELM = DEXP(-ELIM) CELMR = ELM ZDR = ZRR ZDI = ZRI 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 CSR = S2R CSI = S2I S2R = CKR*CSR - CKI*CSI + S1R S2I = CKI*CSR + CKR*CSI + S1I S1R = CSR S1I = CSI CKR = CKR + RZR CKI = CKI + RZI AS = ZABS(S2R,S2I) ALAS = DLOG(AS) ACS = -ZDR + ALAS NZ = NZ + 1 YR(I) = ZEROR YI(I) = ZEROI IF (ACS.LT.(-ELIM)) GO TO 25 CALL ZLOG(S2R, S2I, CSR, CSI, IDUM) CSR = CSR - ZDR CSI = CSI - ZDI STR = DEXP(CSR)/TOL CSR = STR*DCOS(CSI) CSI = STR*DSIN(CSI) CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 25 YR(I) = CSR YI(I) = CSI 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 ZDR = ZDR - ELIM S1R = S1R*CELMR S1I = S1I*CELMR S2R = S2R*CELMR S2I = S2I*CELMR 30 CONTINUE NZ = N IF(IC.EQ.N) NZ=N-1 GO TO 45 40 CONTINUE NZ = KK - 2 45 CONTINUE DO 50 I=1,NZ YR(I) = ZEROR YI(I) = ZEROI 50 CONTINUE RETURN END SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI) C***BEGIN PROLOGUE ZSHCH C***REFER TO ZBESK,ZBESH C C ZSHCH COMPUTES THE COMPLEX 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 ZSHCH C DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR, * DCOSH, DSINH SH = DSINH(ZR) CH = DCOSH(ZR) SN = DSIN(ZI) CN = DCOS(ZI) CSHR = SH*CN CSHI = CH*SN CCHR = CH*CN CCHI = SH*SN RETURN END SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL) C***BEGIN PROLOGUE ZRATI C***REFER TO ZBESI,ZBESK,ZBESH C C ZRATI 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 COMPLEX ARGUMENT AND INTEGER ORDER, C BY D. J. SOOKNE. C C***ROUTINES CALLED ZABS,ZDIV C***END PROLOGUE ZRATI C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU EXTERNAL ZABS DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N DIMENSION CYR(N), CYI(N) DATA CZEROR,CZEROI,CONER,CONEI,RT2/ 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / AZ = ZABS(ZR,ZI) INU = INT(SNGL(FNU)) IDNU = INU + N - 1 MAGZ = INT(SNGL(AZ)) AMAGZ = DBLE(FLOAT(MAGZ+1)) FDNU = DBLE(FLOAT(IDNU)) FNUP = DMAX1(AMAGZ,FDNU) ID = IDNU - MAGZ - 1 ITIME = 1 K = 1 PTR = 1.0D0/AZ RZR = PTR*(ZR+ZR)*PTR RZI = -PTR*(ZI+ZI)*PTR T1R = RZR*FNUP T1I = RZI*FNUP P2R = -T1R P2I = -T1I P1R = CONER P1I = CONEI T1R = T1R + RZR T1I = T1I + RZI IF (ID.GT.0) ID = 0 AP2 = ZABS(P2R,P2I) AP1 = ZABS(P1R,P1I) C----------------------------------------------------------------------- C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU 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 = DSQRT(ARG) TEST = TEST1 RAP1 = 1.0D0/AP1 P1R = P1R*RAP1 P1I = P1I*RAP1 P2R = P2R*RAP1 P2I = P2I*RAP1 AP2 = AP2*RAP1 10 CONTINUE K = K + 1 AP1 = AP2 PTR = P2R PTI = P2I P2R = P1R - (T1R*PTR-T1I*PTI) P2I = P1I - (T1R*PTI+T1I*PTR) P1R = PTR P1I = PTI T1R = T1R + RZR T1I = T1I + RZI AP2 = ZABS(P2R,P2I) IF (AP1.LE.TEST) GO TO 10 IF (ITIME.EQ.2) GO TO 20 AK = ZABS(T1R,T1I)*0.5D0 FLAM = AK + DSQRT(AK*AK-1.0D0) RHO = DMIN1(AP2/AP1,FLAM) TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0)) ITIME = 2 GO TO 10 20 CONTINUE KK = K + 1 - ID AK = DBLE(FLOAT(KK)) T1R = AK T1I = CZEROI DFNU = FNU + DBLE(FLOAT(N-1)) P1R = 1.0D0/AP2 P1I = CZEROI P2R = CZEROR P2I = CZEROI DO 30 I=1,KK PTR = P1R PTI = P1I RAP1 = DFNU + T1R TTR = RZR*RAP1 TTI = RZI*RAP1 P1R = (PTR*TTR-PTI*TTI) + P2R P1I = (PTR*TTI+PTI*TTR) + P2I P2R = PTR P2I = PTI T1R = T1R - CONER 30 CONTINUE IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40 P1R = TOL P1I = TOL 40 CONTINUE CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) IF (N.EQ.1) RETURN K = N - 1 AK = DBLE(FLOAT(K)) T1R = AK T1I = CZEROI CDFNUR = FNU*RZR CDFNUI = FNU*RZI DO 60 I=2,N PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) AK = ZABS(PTR,PTI) IF (AK.NE.CZEROR) GO TO 50 PTR = TOL PTI = TOL AK = TOL*RT2 50 CONTINUE RAK = CONER/AK CYR(K) = RAK*PTR*RAK CYI(K) = -RAK*PTI*RAK T1R = T1R - CONER K = K - 1 60 CONTINUE RETURN END SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, * IUF) C***BEGIN PROLOGUE ZS1S2 C***REFER TO ZBESK,ZAIRY C C ZS1S2 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 ZABS,ZEXP,ZLOG C***END PROLOGUE ZS1S2 C COMPLEX CZERO,C1,S1,S1D,S2,ZR EXTERNAL ZABS DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS INTEGER IUF, IDUM, NZ DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / NZ = 0 AS1 = ZABS(S1R,S1I) AS2 = ZABS(S2R,S2I) IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10 IF (AS1.EQ.0.0D0) GO TO 10 ALN = -ZRR - ZRR + DLOG(AS1) S1DR = S1R S1DI = S1I S1R = ZEROR S1I = ZEROI AS1 = ZEROR IF (ALN.LT.(-ALIM)) GO TO 10 CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM) C1R = C1R - ZRR - ZRR C1I = C1I - ZRI - ZRI CALL ZEXP(C1R, C1I, S1R, S1I) AS1 = ZABS(S1R,S1I) IUF = IUF + 1 10 CONTINUE AA = DMAX1(AS1,AS2) IF (AA.GT.ASCLE) RETURN S1R = ZEROR S1I = ZEROI S2R = ZEROR S2I = ZEROI NZ = 1 IUF = 0 RETURN END SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZBUNK C***REFER TO ZBESK,ZBESH C C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 C C***ROUTINES CALLED ZUNK1,ZUNK2 C***END PROLOGUE ZBUNK C COMPLEX Y,Z DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR INTEGER KODE, MR, N, NZ DIMENSION YR(N), YI(N) NZ = 0 AX = DABS(ZR)*1.7321D0 AY = DABS(ZI) 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 ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, 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 ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) 20 CONTINUE RETURN END SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) C***BEGIN PROLOGUE ZMLRI C***REFER TO ZBESI,ZBESK C C ZMLRI 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 DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT C***END PROLOGUE ZMLRI C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z EXTERNAL ZABS DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, * D1MACH, ZABS INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ DIMENSION YR(N), YI(N) DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / SCLE = D1MACH(1)/TOL NZ=0 AZ = ZABS(ZR,ZI) IAZ = INT(SNGL(AZ)) IFNU = INT(SNGL(FNU)) INU = IFNU + N - 1 AT = DBLE(FLOAT(IAZ)) + 1.0D0 RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ CKR = STR*AT*RAZ CKI = STI*AT*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ P1R = ZEROR P1I = ZEROI P2R = CONER P2I = CONEI ACK = (AT+1.0D0)*RAZ RHO = ACK + DSQRT(ACK*ACK-1.0D0) RHO2 = RHO*RHO TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) TST = TST/TOL C----------------------------------------------------------------------- C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES C----------------------------------------------------------------------- AK = AT DO 10 I=1,80 PTR = P2R PTI = P2I P2R = P1R - (CKR*PTR-CKI*PTI) P2I = P1I - (CKI*PTR+CKR*PTI) P1R = PTR P1I = PTI CKR = CKR + RZR CKI = CKI + RZI AP = ZABS(P2R,P2I) IF (AP.GT.TST*AK*AK) GO TO 20 AK = AK + 1.0D0 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----------------------------------------------------------------------- P1R = ZEROR P1I = ZEROI P2R = CONER P2I = CONEI AT = DBLE(FLOAT(INU)) + 1.0D0 STR = ZR*RAZ STI = -ZI*RAZ CKR = STR*AT*RAZ CKI = STI*AT*RAZ ACK = AT*RAZ TST = DSQRT(ACK/TOL) ITIME = 1 DO 30 K=1,80 PTR = P2R PTI = P2I P2R = P1R - (CKR*PTR-CKI*PTI) P2I = P1I - (CKR*PTI+CKI*PTR) P1R = PTR P1I = PTI CKR = CKR + RZR CKI = CKI + RZI AP = ZABS(P2R,P2I) IF (AP.LT.TST) GO TO 30 IF (ITIME.EQ.2) GO TO 40 ACK = ZABS(CKR,CKI) FLAM = ACK + DSQRT(ACK*ACK-1.0D0) FKAP = AP/ZABS(P1R,P1I) RHO = DMIN1(FLAM,FKAP) TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0)) 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 = DBLE(FLOAT(KK)) P1R = ZEROR P1I = ZEROI C----------------------------------------------------------------------- C SCALE P2 AND SUM BY SCLE C----------------------------------------------------------------------- P2R = SCLE P2I = ZEROI FNF = FNU - DBLE(FLOAT(IFNU)) TFNF = FNF + FNF BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - * DGAMLN(TFNF+1.0D0,IDUM) BK = DEXP(BK) SUMR = ZEROR SUMI = ZEROI KM = KK - INU DO 50 I=1,KM PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 50 CONTINUE YR(N) = P2R YI(N) = P2I IF (N.EQ.1) GO TO 70 DO 60 I=2,N PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 M = N - I + 1 YR(M) = P2R YI(M) = P2I 60 CONTINUE 70 CONTINUE IF (IFNU.LE.0) GO TO 90 DO 80 I=1,IFNU PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 80 CONTINUE 90 CONTINUE PTR = ZR PTI = ZI IF (KODE.EQ.2) PTR = ZEROR CALL ZLOG(RZR, RZI, STR, STI, IDUM) P1R = -FNF*STR + PTR P1I = -FNF*STI + PTI AP = DGAMLN(1.0D0+FNF,IDUM) PTR = P1R - AP PTI = P1I C----------------------------------------------------------------------- C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES C----------------------------------------------------------------------- P2R = P2R + SUMR P2I = P2I + SUMI AP = ZABS(P2R,P2I) P1R = 1.0D0/AP CALL ZEXP(PTR, PTI, STR, STI) CKR = STR*P1R CKI = STI*P1R PTR = P2R*P1R PTI = -P2I*P1R CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) DO 100 I=1,N STR = YR(I)*CNORMR - YI(I)*CNORMI YI(I) = YR(I)*CNORMI + YI(I)*CNORMR YR(I) = STR 100 CONTINUE RETURN 110 CONTINUE NZ=-2 RETURN END SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZWRSK C***REFER TO ZBESI,ZBESK C C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN C C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,ZABS C***END PROLOGUE ZWRSK C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR EXTERNAL ZABS DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH INTEGER I, KODE, N, NW, NZ DIMENSION YR(N), YI(N), CWR(2), CWI(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 ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) IF (NW.NE.0) GO TO 50 CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, 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----------------------------------------------------------------------- CINUR = 1.0D0 CINUI = 0.0D0 IF (KODE.EQ.1) GO TO 10 CINUR = DCOS(ZRI) CINUI = DSIN(ZRI) 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(CWR(2),CWI(2)) ASCLE = 1.0D+3*D1MACH(1)/TOL CSCLR = 1.0D0 IF (ACW.GT.ASCLE) GO TO 20 CSCLR = 1.0D0/TOL GO TO 30 20 CONTINUE ASCLE = 1.0D0/ASCLE IF (ACW.LT.ASCLE) GO TO 30 CSCLR = TOL 30 CONTINUE C1R = CWR(1)*CSCLR C1I = CWI(1)*CSCLR C2R = CWR(2)*CSCLR C2I = CWI(2)*CSCLR STR = YR(1) STI = YI(1) C----------------------------------------------------------------------- C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) C----------------------------------------------------------------------- PTR = STR*C1R - STI*C1I PTI = STR*C1I + STI*C1R PTR = PTR + C2R PTI = PTI + C2I CTR = ZRR*PTR - ZRI*PTI CTI = ZRR*PTI + ZRI*PTR ACT = ZABS(CTR,CTI) RACT = 1.0D0/ACT CTR = CTR*RACT CTI = -CTI*RACT PTR = CINUR*RACT PTI = CINUI*RACT CINUR = PTR*CTR - PTI*CTI CINUI = PTR*CTI + PTI*CTR YR(1) = CINUR*CSCLR YI(1) = CINUI*CSCLR IF (N.EQ.1) RETURN DO 40 I=2,N PTR = STR*CINUR - STI*CINUI CINUI = STR*CINUI + STI*CINUR CINUR = PTR STR = YR(I) STI = YI(I) YR(I) = CINUR*CSCLR YI(I) = CINUI*CSCLR 40 CONTINUE RETURN 50 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN END SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZSERI C***REFER TO ZBESI,ZBESK C C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE C REGION CABS(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 CABS(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 DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT C***END PROLOGUE ZSERI C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z EXTERNAL ZABS DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, * ZR, DGAMLN, D1MACH, ZABS INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW DIMENSION YR(N), YI(N), WR(2), WI(2) DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / C NZ = 0 AZ = ZABS(ZR,ZI) IF (AZ.EQ.0.0D0) GO TO 160 ARM = 1.0D+3*D1MACH(1) RTR1 = DSQRT(ARM) CRSCR = 1.0D0 IFLAG = 0 IF (AZ.LT.ARM) GO TO 150 HZR = 0.5D0*ZR HZI = 0.5D0*ZI CZR = ZEROR CZI = ZEROI IF (AZ.LE.RTR1) GO TO 10 CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) 10 CONTINUE ACZ = ZABS(CZR,CZI) NN = N CALL ZLOG(HZR, HZI, CKR, CKI, IDUM) 20 CONTINUE DFNU = FNU + DBLE(FLOAT(NN-1)) FNUP = DFNU + 1.0D0 C----------------------------------------------------------------------- C UNDERFLOW TEST C----------------------------------------------------------------------- AK1R = CKR*DFNU AK1I = CKI*DFNU AK = DGAMLN(FNUP,IDUM) AK1R = AK1R - AK IF (KODE.EQ.2) AK1R = AK1R - ZR IF (AK1R.GT.(-ELIM)) GO TO 40 30 CONTINUE NZ = NZ + 1 YR(NN) = ZEROR YI(NN) = ZEROI IF (ACZ.GT.DFNU) GO TO 190 NN = NN - 1 IF (NN.EQ.0) RETURN GO TO 20 40 CONTINUE IF (AK1R.GT.(-ALIM)) GO TO 50 IFLAG = 1 SS = 1.0D0/TOL CRSCR = TOL ASCLE = ARM*SS 50 CONTINUE AA = DEXP(AK1R) IF (IFLAG.EQ.1) AA = AA*SS COEFR = AA*DCOS(AK1I) COEFI = AA*DSIN(AK1I) ATOL = TOL*ACZ/FNUP IL = MIN0(2,NN) DO 90 I=1,IL DFNU = FNU + DBLE(FLOAT(NN-I)) FNUP = DFNU + 1.0D0 S1R = CONER S1I = CONEI IF (ACZ.LT.TOL*FNUP) GO TO 70 AK1R = CONER AK1I = CONEI AK = FNUP + 2.0D0 S = FNUP AA = 2.0D0 60 CONTINUE RS = 1.0D0/S STR = AK1R*CZR - AK1I*CZI STI = AK1R*CZI + AK1I*CZR AK1R = STR*RS AK1I = STI*RS S1R = S1R + AK1R S1I = S1I + AK1I S = S + AK AK = AK + 2.0D0 AA = AA*ACZ*RS IF (AA.GT.ATOL) GO TO 60 70 CONTINUE S2R = S1R*COEFR - S1I*COEFI S2I = S1R*COEFI + S1I*COEFR WR(I) = S2R WI(I) = S2I IF (IFLAG.EQ.0) GO TO 80 CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 30 80 CONTINUE M = NN - I + 1 YR(M) = S2R*CRSCR YI(M) = S2I*CRSCR IF (I.EQ.IL) GO TO 90 CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) COEFR = STR*DFNU COEFI = STI*DFNU 90 CONTINUE IF (NN.LE.2) RETURN K = NN - 2 AK = DBLE(FLOAT(K)) RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ IF (IFLAG.EQ.1) GO TO 120 IB = 3 100 CONTINUE DO 110 I=IB,NN YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) AK = AK - 1.0D0 K = K - 1 110 CONTINUE RETURN C----------------------------------------------------------------------- C RECUR BACKWARD WITH SCALED VALUES C----------------------------------------------------------------------- 120 CONTINUE C----------------------------------------------------------------------- C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 C----------------------------------------------------------------------- S1R = WR(1) S1I = WI(1) S2R = WR(2) S2I = WI(2) DO 130 L=3,NN CKR = S2R CKI = S2I S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) S1R = CKR S1I = CKI CKR = S2R*CRSCR CKI = S2I*CRSCR YR(K) = CKR YI(K) = CKI AK = AK - 1.0D0 K = K - 1 IF (ZABS(CKR,CKI).GT.ASCLE) GO TO 140 130 CONTINUE RETURN 140 CONTINUE IB = L + 1 IF (IB.GT.NN) RETURN GO TO 100 150 CONTINUE NZ = N IF (FNU.EQ.0.0D0) NZ = NZ - 1 160 CONTINUE YR(1) = ZEROR YI(1) = ZEROI IF (FNU.NE.0.0D0) GO TO 170 YR(1) = CONER YI(1) = CONEI 170 CONTINUE IF (N.EQ.1) RETURN DO 180 I=2,N YR(I) = ZEROR YI(I) = ZEROI 180 CONTINUE RETURN C----------------------------------------------------------------------- C RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE C THE CALCULATION IN CBINU WITH N=N-IABS(NZ) C----------------------------------------------------------------------- 190 CONTINUE NZ = -NZ RETURN END SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZASYI C***REFER TO ZBESI,ZBESK C C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. C C***ROUTINES CALLED D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT C***END PROLOGUE ZASYI C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z EXTERNAL ZABS DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ DIMENSION YR(N), YI(N) DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / C NZ = 0 AZ = ZABS(ZR,ZI) ARM = 1.0D+3*D1MACH(1) RTR1 = DSQRT(ARM) IL = MIN0(2,N) DFNU = FNU + DBLE(FLOAT(N-IL)) C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ AK1R = RTPI*STR*RAZ AK1I = RTPI*STI*RAZ CALL ZSQRT(AK1R, AK1I, AK1R, AK1I) CZR = ZR CZI = ZI IF (KODE.NE.2) GO TO 10 CZR = ZEROR CZI = ZI 10 CONTINUE IF (DABS(CZR).GT.ELIM) GO TO 100 DNU2 = DFNU + DFNU KODED = 1 IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20 KODED = 0 CALL ZEXP(CZR, CZI, STR, STI) CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) 20 CONTINUE FDN = 0.0D0 IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 EZR = ZR*8.0D0 EZI = ZI*8.0D0 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.0D0*AZ S = TOL/AEZ JL = INT(SNGL(RL+RL)) + 2 P1R = ZEROR P1I = ZEROI IF (ZI.EQ.0.0D0) GO TO 30 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(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*PI INU = INU + N - IL AK = -DSIN(ARG) BK = DCOS(ARG) IF (ZI.LT.0.0D0) BK = -BK P1R = AK P1I = BK IF (MOD(INU,2).EQ.0) GO TO 30 P1R = -P1R P1I = -P1I 30 CONTINUE DO 70 K=1,IL SQK = FDN - 1.0D0 ATOL = S*DABS(SQK) SGN = 1.0D0 CS1R = CONER CS1I = CONEI CS2R = CONER CS2I = CONEI CKR = CONER CKI = CONEI AK = 0.0D0 AA = 1.0D0 BB = AEZ DKR = EZR DKI = EZI DO 40 J=1,JL CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI) CKR = STR*SQK CKI = STI*SQK CS2R = CS2R + CKR CS2I = CS2I + CKI SGN = -SGN CS1R = CS1R + CKR*SGN CS1I = CS1I + CKI*SGN DKR = DKR + EZR DKI = DKI + EZI AA = AA*DABS(SQK)/BB BB = BB + AEZ AK = AK + 8.0D0 SQK = SQK - AK IF (AA.LE.ATOL) GO TO 50 40 CONTINUE GO TO 110 50 CONTINUE S2R = CS1R S2I = CS1I IF (ZR+ZR.GE.ELIM) GO TO 60 TZR = ZR + ZR TZI = ZI + ZI CALL ZEXP(-TZR, -TZI, STR, STI) CALL ZMLT(STR, STI, P1R, P1I, STR, STI) CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI) S2R = S2R + STR S2I = S2I + STI 60 CONTINUE FDN = FDN + 8.0D0*DFNU + 4.0D0 P1R = -P1R P1I = -P1I M = N - IL + K YR(M) = S2R*AK1R - S2I*AK1I YI(M) = S2R*AK1I + S2I*AK1R 70 CONTINUE IF (N.LE.2) RETURN NN = N K = NN - 2 AK = DBLE(FLOAT(K)) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ IB = 3 DO 80 I=IB,NN YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) AK = AK - 1.0D0 K = K - 1 80 CONTINUE IF (KODED.EQ.0) RETURN CALL ZEXP(CZR, CZI, CKR, CKI) DO 90 I=1,NN STR = YR(I)*CKR - YI(I)*CKI YI(I) = YR(I)*CKI + YI(I)*CKR YR(I) = STR 90 CONTINUE RETURN 100 CONTINUE NZ = -1 RETURN 110 CONTINUE NZ=-2 RETURN END SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, * ELIM, ALIM) C***BEGIN PROLOGUE ZUOIK C***REFER TO ZBESI,ZBESK,ZBESH C C ZUOIK 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 ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG C***END PROLOGUE ZUOIK C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, C *ZR EXTERNAL ZABS DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / DATA AIC / 1.265512123484645396D+00 / NUF = 0 NN = N ZRR = ZR ZRI = ZI IF (ZR.GE.0.0D0) GO TO 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE ZBR = ZRR ZBI = ZRI AX = DABS(ZR)*1.7321D0 AY = DABS(ZI) IFORM = 1 IF (AY.GT.AX) IFORM = 2 GNU = DMAX1(FNU,1.0D0) IF (IKFLG.EQ.1) GO TO 20 FNN = DBLE(FLOAT(NN)) GNN = FNU + FNN - 1.0D0 GNU = DMAX1(GNN,FNN) 20 CONTINUE C----------------------------------------------------------------------- C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE C REAL 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 30 INIT = 0 CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I GO TO 50 30 CONTINUE ZNR = ZRI ZNI = -ZRR IF (ZI.GT.0.0D0) GO TO 40 ZNR = -ZNR 40 CONTINUE CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I AARG = ZABS(ARGR,ARGI) 50 CONTINUE IF (KODE.EQ.1) GO TO 60 CZR = CZR - ZBR CZI = CZI - ZBI 60 CONTINUE IF (IKFLG.EQ.1) GO TO 70 CZR = -CZR CZI = -CZI 70 CONTINUE APHI = ZABS(PHIR,PHII) RCZ = CZR C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- IF (RCZ.GT.ELIM) GO TO 210 IF (RCZ.LT.ALIM) GO TO 80 RCZ = RCZ + DLOG(APHI) IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC IF (RCZ.GT.ELIM) GO TO 210 GO TO 130 80 CONTINUE C----------------------------------------------------------------------- C UNDERFLOW TEST C----------------------------------------------------------------------- IF (RCZ.LT.(-ELIM)) GO TO 90 IF (RCZ.GT.(-ALIM)) GO TO 130 RCZ = RCZ + DLOG(APHI) IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC IF (RCZ.GT.(-ELIM)) GO TO 110 90 CONTINUE DO 100 I=1,NN YR(I) = ZEROR YI(I) = ZEROI 100 CONTINUE NUF = NN RETURN 110 CONTINUE ASCLE = 1.0D+3*D1MACH(1)/TOL CALL ZLOG(PHIR, PHII, STR, STI, IDUM) CZR = CZR + STR CZI = CZI + STI IF (IFORM.EQ.1) GO TO 120 CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) CZR = CZR - 0.25D0*STR - AIC CZI = CZI - 0.25D0*STI 120 CONTINUE AX = DEXP(RCZ)/TOL AY = CZI CZR = AX*DCOS(AY) CZI = AX*DSIN(AY) CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 90 130 CONTINUE IF (IKFLG.EQ.2) RETURN IF (N.EQ.1) RETURN C----------------------------------------------------------------------- C SET UNDERFLOWS ON I SEQUENCE C----------------------------------------------------------------------- 140 CONTINUE GNU = FNU + DBLE(FLOAT(NN-1)) IF (IFORM.EQ.2) GO TO 150 INIT = 0 CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I GO TO 160 150 CONTINUE CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I AARG = ZABS(ARGR,ARGI) 160 CONTINUE IF (KODE.EQ.1) GO TO 170 CZR = CZR - ZBR CZI = CZI - ZBI 170 CONTINUE APHI = ZABS(PHIR,PHII) RCZ = CZR IF (RCZ.LT.(-ELIM)) GO TO 180 IF (RCZ.GT.(-ALIM)) RETURN RCZ = RCZ + DLOG(APHI) IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC IF (RCZ.GT.(-ELIM)) GO TO 190 180 CONTINUE YR(NN) = ZEROR YI(NN) = ZEROI NN = NN - 1 NUF = NUF + 1 IF (NN.EQ.0) RETURN GO TO 140 190 CONTINUE ASCLE = 1.0D+3*D1MACH(1)/TOL CALL ZLOG(PHIR, PHII, STR, STI, IDUM) CZR = CZR + STR CZI = CZI + STI IF (IFORM.EQ.1) GO TO 200 CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) CZR = CZR - 0.25D0*STR - AIC CZI = CZI - 0.25D0*STI 200 CONTINUE AX = DEXP(RCZ)/TOL AY = CZI CZR = AX*DCOS(AY) CZI = AX*DSIN(AY) CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 180 RETURN 210 CONTINUE NUF = -1 RETURN END SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZACON C***REFER TO ZBESK,ZBESH C C ZACON 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*CMPLX(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 ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT C***END PROLOGUE ZACON C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, C *S1,S2,Y,Z,ZN EXTERNAL ZABS DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) DATA PI / 3.14159265358979324D0 / DATA ZEROR,CONER / 0.0D0,1.0D0 / NZ = 0 ZNR = -ZR ZNI = -ZI NN = N CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, * ELIM, ALIM) IF (NW.LT.0) GO TO 90 C----------------------------------------------------------------------- C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION C----------------------------------------------------------------------- NN = MIN0(2,N) CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) IF (NW.NE.0) GO TO 90 S1R = CYR(1) S1I = CYI(1) FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) CSGNR = ZEROR CSGNI = SGN IF (KODE.EQ.1) GO TO 10 YY = -ZNI CPN = DCOS(YY) SPN = DSIN(YY) CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) 10 CONTINUE C----------------------------------------------------------------------- C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*SGN CPN = DCOS(ARG) SPN = DSIN(ARG) CSPNR = CPN CSPNI = SPN IF (MOD(INU,2).EQ.0) GO TO 20 CSPNR = -CSPNR CSPNI = -CSPNI 20 CONTINUE IUF = 0 C1R = S1R C1I = S1I C2R = YR(1) C2I = YI(1) ASCLE = 1.0D+3*D1MACH(1)/TOL IF (KODE.EQ.1) GO TO 30 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1R = C1R SC1I = C1I 30 CONTINUE CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) YR(1) = STR + PTR YI(1) = STI + PTI IF (N.EQ.1) RETURN CSPNR = -CSPNR CSPNI = -CSPNI S2R = CYR(2) S2I = CYI(2) C1R = S2R C1I = S2I C2R = YR(2) C2I = YI(2) IF (KODE.EQ.1) GO TO 40 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC2R = C1R SC2I = C1I 40 CONTINUE CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) YR(2) = STR + PTR YI(2) = STI + PTI IF (N.EQ.2) RETURN CSPNR = -CSPNR CSPNI = -CSPNI AZN = ZABS(ZNR,ZNI) RAZN = 1.0D0/AZN STR = ZNR*RAZN STI = -ZNI*RAZN RZR = (STR+STR)*RAZN RZI = (STI+STI)*RAZN FN = FNU + 1.0D0 CKR = FN*RZR CKI = FN*RZI C----------------------------------------------------------------------- C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CSCR = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CSCR CSRR(1) = CSCR CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = ASCLE BRY(2) = 1.0D0/ASCLE BRY(3) = D1MACH(2) AS2 = ZABS(S2R,S2I) KFLAG = 2 IF (AS2.GT.BRY(1)) GO TO 50 KFLAG = 1 GO TO 60 50 CONTINUE IF (AS2.LT.BRY(2)) GO TO 60 KFLAG = 3 60 CONTINUE BSCLE = BRY(KFLAG) S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) CSR = CSRR(KFLAG) DO 80 I=3,N STR = S2R STI = S2I S2R = CKR*STR - CKI*STI + S1R S2I = CKR*STI + CKI*STR + S1I S1R = STR S1I = STI C1R = S2R*CSR C1I = S2I*CSR STR = C1R STI = C1I C2R = YR(I) C2I = YI(I) IF (KODE.EQ.1) GO TO 70 IF (IUF.LT.0) GO TO 70 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1R = SC2R SC1I = SC2I SC2R = C1R SC2I = C1I IF (IUF.NE.3) GO TO 70 IUF = -4 S1R = SC1R*CSSR(KFLAG) S1I = SC1I*CSSR(KFLAG) S2R = SC2R*CSSR(KFLAG) S2I = SC2I*CSSR(KFLAG) STR = SC2R STI = SC2I 70 CONTINUE PTR = CSPNR*C1R - CSPNI*C1I PTI = CSPNR*C1I + CSPNI*C1R YR(I) = PTR + CSGNR*C2R - CSGNI*C2I YI(I) = PTI + CSGNR*C2I + CSGNI*C2R CKR = CKR + RZR CKI = CKI + RZI CSPNR = -CSPNR CSPNI = -CSPNI IF (KFLAG.GE.3) GO TO 80 PTR = DABS(C1R) PTI = DABS(C1I) C1M = DMAX1(PTR,PTI) IF (C1M.LE.BSCLE) GO TO 80 KFLAG = KFLAG + 1 BSCLE = BRY(KFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = STR S2I = STI S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) CSR = CSRR(KFLAG) 80 CONTINUE RETURN 90 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN END SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZBINU C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY C C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE C C***ROUTINES CALLED ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK C***END PROLOGUE ZBINU EXTERNAL ZABS DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / C NZ = 0 AZ = ZABS(ZR,ZI) NN = N DFNU = FNU + DBLE(FLOAT(N-1)) IF (AZ.LE.2.0D0) GO TO 10 IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 10 CONTINUE C----------------------------------------------------------------------- C POWER SERIES C----------------------------------------------------------------------- CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, 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 + DBLE(FLOAT(NN-1)) 20 CONTINUE IF (AZ.LT.RL) GO TO 40 IF (DFNU.LE.1.0D0) GO TO 30 IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR LARGE Z C----------------------------------------------------------------------- 30 CONTINUE CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 130 GO TO 120 40 CONTINUE IF (DFNU.LE.1.0D0) GO TO 70 50 CONTINUE C----------------------------------------------------------------------- C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM C----------------------------------------------------------------------- CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 130 NZ = NZ + NW NN = NN - NW IF (NN.EQ.0) RETURN DFNU = FNU+DBLE(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----------------------------------------------------------------------- CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, 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----------------------------------------------------------------------- CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, * ALIM) IF (NW.GE.0) GO TO 100 NZ = NN DO 90 I=1,NN CYR(I) = ZEROR CYI(I) = ZEROI 90 CONTINUE RETURN 100 CONTINUE IF (NW.GT.0) GO TO 130 CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, 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(SNGL(FNUL-DFNU)) + 1 NUI = MAX0(NUI,0) CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, 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 DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR) C***BEGIN PROLOGUE DGAMLN 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 **** A DOUBLE PRECISION ROUTINE **** C DGAMLN 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=AMAX1(-ALOG10(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 Z IS D0UBLE PRECISION C Z - ARGUMENT, Z.GT.0.0D0 C C OUTPUT DGAMLN IS DOUBLE PRECISION C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 C IERR - ERROR FLAG C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED C IERR=1, Z.LE.0.0D0, NO COMPUTATION C C C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C***ROUTINES CALLED I1MACH,D1MACH C***END PROLOGUE DGAMLN DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH 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.00000000000000000D+00, 0.00000000000000000D+00, 5 6.93147180559945309D-01, 1.79175946922805500D+00, 6 3.17805383034794562D+00, 4.78749174278204599D+00, 7 6.57925121201010100D+00, 8.52516136106541430D+00, 8 1.06046029027452502D+01, 1.28018274800814696D+01, 9 1.51044125730755153D+01, 1.75023078458738858D+01, A 1.99872144956618861D+01, 2.25521638531234229D+01, B 2.51912211827386815D+01, 2.78992713838408916D+01, C 3.06718601060806728D+01, 3.35050734501368889D+01, D 3.63954452080330536D+01, 3.93398841871994940D+01, E 4.23356164607534850D+01, 4.53801388984769080D+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.84711813518352239D+01, 5.16066755677643736D+01, 5 5.47847293981123192D+01, 5.80036052229805199D+01, 6 6.12617017610020020D+01, 6.45575386270063311D+01, 7 6.78897431371815350D+01, 7.12570389671680090D+01, 8 7.46582363488301644D+01, 7.80922235533153106D+01, 9 8.15579594561150372D+01, 8.50544670175815174D+01, A 8.85808275421976788D+01, 9.21361756036870925D+01, B 9.57196945421432025D+01, 9.93306124547874269D+01, C 1.02968198614513813D+02, 1.06631760260643459D+02, D 1.10320639714757395D+02, 1.14034211781461703D+02, E 1.17771881399745072D+02, 1.21533081515438634D+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.25317271149356895D+02, 1.29123933639127215D+02, 5 1.32952575035616310D+02, 1.36802722637326368D+02, 6 1.40673923648234259D+02, 1.44565743946344886D+02, 7 1.48477766951773032D+02, 1.52409592584497358D+02, 8 1.56360836303078785D+02, 1.60331128216630907D+02, 9 1.64320112263195181D+02, 1.68327445448427652D+02, A 1.72352797139162802D+02, 1.76395848406997352D+02, B 1.80456291417543771D+02, 1.84533828861449491D+02, C 1.88628173423671591D+02, 1.92739047287844902D+02, D 1.96866181672889994D+02, 2.01009316399281527D+02, E 2.05168199482641199D+02, 2.09342586752536836D+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.13532241494563261D+02, 2.17736934113954227D+02, 5 2.21956441819130334D+02, 2.26190548323727593D+02, 6 2.30439043565776952D+02, 2.34701723442818268D+02, 7 2.38978389561834323D+02, 2.43268849002982714D+02, 8 2.47572914096186884D+02, 2.51890402209723194D+02, 9 2.56221135550009525D+02, 2.60564940971863209D+02, A 2.64921649798552801D+02, 2.69291097651019823D+02, B 2.73673124285693704D+02, 2.78067573440366143D+02, C 2.82474292687630396D+02, 2.86893133295426994D+02, D 2.91323950094270308D+02, 2.95766601350760624D+02, E 3.00220948647014132D+02, 3.04686856765668715D+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.09164193580146922D+02, 3.13652829949879062D+02, 3 3.18152639620209327D+02, 3.22663499126726177D+02, 4 3.27185287703775217D+02, 3.31717887196928473D+02, 5 3.36261181979198477D+02, 3.40815058870799018D+02, 6 3.45379407062266854D+02, 3.49954118040770237D+02, 7 3.54539085519440809D+02, 3.59134205369575399D+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.33333333333333333D-02, -2.77777777777777778D-03, 4 7.93650793650793651D-04, -5.95238095238095238D-04, 5 8.41750841750841751D-04, -1.91752691752691753D-03, 6 6.41025641025641026D-03, -2.95506535947712418D-02, 7 1.79644372368830573D-01, -1.39243221690590112D+00, 8 1.34028640441683920D+01, -1.56848284626002017D+02, 9 2.19310333333333333D+03, -3.61087712537249894D+04, A 6.91472268851313067D+05, -1.52382215394074162D+07, B 3.82900751391414141D+08, -1.08822660357843911D+10, C 3.47320283765002252D+11, -1.23696021422692745D+13, D 4.88788064793079335D+14, -2.13203339609193739D+16/ C C LN(2*PI) DATA CON / 1.83787706640934548D+00/ C C***FIRST EXECUTABLE STATEMENT DGAMLN IERR=0 IF (Z.LE.0.0D0) GO TO 70 IF (Z.GT.101.0D0) GO TO 10 NZ = INT(Z) FZ = Z - FLOAT(NZ) IF (FZ.GT.0.0D0) GO TO 10 IF (NZ.GT.100) GO TO 10 DGAMLN = GLN(NZ) RETURN 10 CONTINUE WDTOL = D1MACH(4) WDTOL = DMAX1(WDTOL,0.5D-18) I1M = I1MACH(14) RLN = D1MACH(5)*FLOAT(I1M) FLN = DMIN1(RLN,20.0D0) FLN = DMAX1(FLN,3.0D0) FLN = FLN - 3.0D0 ZM = 1.8000D0 + 0.3875D0*FLN MZ = INT(SNGL(ZM)) + 1 ZMIN = FLOAT(MZ) ZDMY = Z ZINC = 0.0D0 IF (Z.GE.ZMIN) GO TO 20 ZINC = ZMIN - FLOAT(NZ) ZDMY = Z + ZINC 20 CONTINUE ZP = 1.0D0/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 (DABS(TRM).LT.TST) GO TO 40 S = S + TRM 30 CONTINUE 40 CONTINUE IF (ZINC.NE.0.0D0) GO TO 50 TLG = DLOG(Z) DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S RETURN 50 CONTINUE ZP = 1.0D0 NZ = INT(SNGL(ZINC)) DO 60 I=1,NZ ZP = ZP*(Z+FLOAT(I-1)) 60 CONTINUE TLG = DLOG(ZDMY) DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S RETURN C C 70 CONTINUE IERR=1 RETURN END SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, * ELIM, ALIM) C***BEGIN PROLOGUE ZACAI C***REFER TO ZAIRY C C ZACAI 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*CMPLX(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 ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON C IS CALLED FROM ZAIRY. C C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS C***END PROLOGUE ZACAI C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY EXTERNAL ZABS DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2) DATA PI / 3.14159265358979324D0 / NZ = 0 ZNR = -ZR ZNI = -ZI AZ = ZABS(ZR,ZI) NN = N DFNU = FNU + DBLE(FLOAT(N-1)) IF (AZ.LE.2.0D0) GO TO 10 IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 10 CONTINUE C----------------------------------------------------------------------- C POWER SERIES FOR THE I FUNCTION C----------------------------------------------------------------------- CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, 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 ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 80 GO TO 40 30 CONTINUE C----------------------------------------------------------------------- C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION C----------------------------------------------------------------------- CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) IF(NW.LT.0) GO TO 80 40 CONTINUE C----------------------------------------------------------------------- C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION C----------------------------------------------------------------------- CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) IF (NW.NE.0) GO TO 80 FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) CSGNR = 0.0D0 CSGNI = SGN IF (KODE.EQ.1) GO TO 50 YY = -ZNI CSGNR = -CSGNI*DSIN(YY) CSGNI = CSGNI*DCOS(YY) 50 CONTINUE C----------------------------------------------------------------------- C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*SGN CSPNR = DCOS(ARG) CSPNI = DSIN(ARG) IF (MOD(INU,2).EQ.0) GO TO 60 CSPNR = -CSPNR CSPNI = -CSPNI 60 CONTINUE C1R = CYR(1) C1I = CYI(1) C2R = YR(1) C2I = YI(1) IF (KODE.EQ.1) GO TO 70 IUF = 0 ASCLE = 1.0D+3*D1MACH(1)/TOL CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW 70 CONTINUE YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R RETURN 80 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN END SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL) C***BEGIN PROLOGUE ZUCHK C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL C C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW 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 ZUCHK C C COMPLEX Y DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI INTEGER NZ NZ = 0 WR = DABS(YR) WI = DABS(YI) ST = DMIN1(WR,WI) IF (ST.GT.ASCLE) RETURN SS = DMAX1(WR,WI) ST = ST/TOL IF (SS.LT.ST) NZ = 1 RETURN END SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, * PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) C***BEGIN PROLOGUE ZUNIK C***REFER TO ZBESI,ZBESK C C ZUNIK 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 COMPLEX WORK C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, C ZETA1,ZETA2. C C***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH C***END PROLOGUE ZUNIK C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, C *ZETA2,ZN,ZR DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / DATA CON(1), CON(2) / 1 3.98942280401432678D-01, 1.25331413731550025D+00 / 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.00000000000000000D+00, -2.08333333333333333D-01, 4 1.25000000000000000D-01, 3.34201388888888889D-01, 5 -4.01041666666666667D-01, 7.03125000000000000D-02, 6 -1.02581259645061728D+00, 1.84646267361111111D+00, 7 -8.91210937500000000D-01, 7.32421875000000000D-02, 8 4.66958442342624743D+00, -1.12070026162229938D+01, 9 8.78912353515625000D+00, -2.36408691406250000D+00, A 1.12152099609375000D-01, -2.82120725582002449D+01, B 8.46362176746007346D+01, -9.18182415432400174D+01, C 4.25349987453884549D+01, -7.36879435947963170D+00, D 2.27108001708984375D-01, 2.12570130039217123D+02, E -7.65252468141181642D+02, 1.05999045252799988D+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.99579627376132541D+02, 2.18190511744211590D+02, 4 -2.64914304869515555D+01, 5.72501420974731445D-01, 5 -1.91945766231840700D+03, 8.06172218173730938D+03, 6 -1.35865500064341374D+04, 1.16553933368645332D+04, 7 -5.30564697861340311D+03, 1.20090291321635246D+03, 8 -1.08090919788394656D+02, 1.72772750258445740D+00, 9 2.02042913309661486D+04, -9.69805983886375135D+04, A 1.92547001232531532D+05, -2.03400177280415534D+05, B 1.22200464983017460D+05, -4.11926549688975513D+04, C 7.10951430248936372D+03, -4.93915304773088012D+02, D 6.07404200127348304D+00, -2.42919187900551333D+05, E 1.31176361466297720D+06, -2.99801591853810675D+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.76327129765640400D+06, -2.81356322658653411D+06, 4 1.26836527332162478D+06, -3.31645172484563578D+05, 5 4.52187689813627263D+04, -2.49983048181120962D+03, 6 2.43805296995560639D+01, 3.28446985307203782D+06, 7 -1.97068191184322269D+07, 5.09526024926646422D+07, 8 -7.41051482115326577D+07, 6.63445122747290267D+07, 9 -3.75671766607633513D+07, 1.32887671664218183D+07, A -2.78561812808645469D+06, 3.08186404612662398D+05, B -1.38860897537170405D+04, 1.10017140269246738D+02, C -4.93292536645099620D+07, 3.25573074185765749D+08, D -9.39462359681578403D+08, 1.55359689957058006D+09, E -1.62108055210833708D+09, 1.10684281682301447D+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.95889784275030309D+08, 1.42062907797533095D+08, 4 -2.44740627257387285D+07, 2.24376817792244943D+06, 5 -8.40054336030240853D+04, 5.51335896122020586D+02, 6 8.14789096118312115D+08, -5.86648149205184723D+09, 7 1.86882075092958249D+10, -3.46320433881587779D+10, 8 4.12801855797539740D+10, -3.30265997498007231D+10, 9 1.79542137311556001D+10, -6.56329379261928433D+09, A 1.55927986487925751D+09, -2.25105661889415278D+08, B 1.73951075539781645D+07, -5.49842327572288687D+05, C 3.03809051092238427D+03, -1.46792612476956167D+10, D 1.14498237732025810D+11, -3.99096175224466498D+11, E 8.19218669548577329D+11, -1.09837515608122331D+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.00815810686538209D+12, -6.45364869245376503D+11, 4 2.87900649906150589D+11, -8.78670721780232657D+10, 5 1.76347306068349694D+10, -2.16716498322379509D+09, 6 1.43157876718888981D+08, -3.87183344257261262D+06, 7 1.82577554742931747D+04, 2.86464035717679043D+11, 8 -2.40629790002850396D+12, 9.10934118523989896D+12, 9 -2.05168994109344374D+13, 3.05651255199353206D+13, A -3.16670885847851584D+13, 2.33483640445818409D+13, B -1.23204913055982872D+13, 4.61272578084913197D+12, C -1.19655288019618160D+12, 2.05914503232410016D+11, D -2.18229277575292237D+10, 1.24700929351271032D+09/ DATA C(119), C(120)/ 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ C IF (INIT.NE.0) GO TO 40 C----------------------------------------------------------------------- C INITIALIZE ALL VARIABLES C----------------------------------------------------------------------- RFN = 1.0D0/FNU C----------------------------------------------------------------------- C OVERFLOW TEST (ZR/FNU TOO SMALL) C----------------------------------------------------------------------- TEST = D1MACH(1)*1.0D+3 AC = FNU*TEST IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15 ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU ZETA1I = 0.0D0 ZETA2R = FNU ZETA2I = 0.0D0 PHIR = 1.0D0 PHII = 0.0D0 RETURN 15 CONTINUE TR = ZRR*RFN TI = ZRI*RFN SR = CONER + (TR*TR-TI*TI) SI = CONEI + (TR*TI+TI*TR) CALL ZSQRT(SR, SI, SRR, SRI) STR = CONER + SRR STI = CONEI + SRI CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) ZETA1R = FNU*STR ZETA1I = FNU*STI ZETA2R = FNU*SRR ZETA2I = FNU*SRI CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) SRR = TR*RFN SRI = TI*RFN CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) PHIR = CWRKR(16)*CON(IKFLG) PHII = CWRKI(16)*CON(IKFLG) IF (IPMTR.NE.0) RETURN CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) CWRKR(1) = CONER CWRKI(1) = CONEI CRFNR = CONER CRFNI = CONEI AC = 1.0D0 L = 1 DO 20 K=2,15 SR = ZEROR SI = ZEROI DO 10 J=1,K L = L + 1 STR = SR*T2R - SI*T2I + C(L) SI = SR*T2I + SI*T2R SR = STR 10 CONTINUE STR = CRFNR*SRR - CRFNI*SRI CRFNI = CRFNR*SRI + CRFNI*SRR CRFNR = STR CWRKR(K) = CRFNR*SR - CRFNI*SI CWRKI(K) = CRFNR*SI + CRFNI*SR AC = AC*RFN TEST = DABS(CWRKR(K)) + DABS(CWRKI(K)) 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----------------------------------------------------------------------- SR = ZEROR SI = ZEROI DO 50 I=1,INIT SR = SR + CWRKR(I) SI = SI + CWRKI(I) 50 CONTINUE SUMR = SR SUMI = SI PHIR = CWRKR(16)*CON(1) PHII = CWRKI(16)*CON(1) RETURN 60 CONTINUE C----------------------------------------------------------------------- C COMPUTE SUM FOR THE K FUNCTION C----------------------------------------------------------------------- SR = ZEROR SI = ZEROI TR = CONER DO 70 I=1,INIT SR = SR + TR*CWRKR(I) SI = SI + TR*CWRKI(I) TR = -TR 70 CONTINUE SUMR = SR SUMI = SI PHIR = CWRKR(16)*CON(2) PHII = CWRKI(16)*CON(2) RETURN END SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) C***BEGIN PROLOGUE ZUNHJ C***REFER TO ZBESI,ZBESK 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 ZUNHJ 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*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. C C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. C C***ROUTINES CALLED ZABS,ZDIV,ZLOG,ZSQRT,D1MACH C***END PROLOGUE ZUNHJ C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, C *ZETA2,ZTH EXTERNAL ZABS DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, * LRP1, L1, L2, M, IDUM DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), * DRR(14), DRI(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.00000000000000000D+00, 1.04166666666666667D-01, 3 8.35503472222222222D-02, 1.28226574556327160D-01, 4 2.91849026464140464D-01, 8.81627267443757652D-01, 5 3.32140828186276754D+00, 1.49957629868625547D+01, 6 7.89230130115865181D+01, 4.74451538868264323D+02, 7 3.20749009089066193D+03, 2.40865496408740049D+04, 8 1.98923119169509794D+05, 1.79190200777534383D+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.00000000000000000D+00, -1.45833333333333333D-01, 3 -9.87413194444444444D-02, -1.43312053915895062D-01, 4 -3.17227202678413548D-01, -9.42429147957120249D-01, 5 -3.51120304082635426D+00, -1.57272636203680451D+01, 6 -8.22814390971859444D+01, -4.92355370523670524D+02, 7 -3.31621856854797251D+03, -2.48276742452085896D+04, 8 -2.04526587315129788D+05, -1.83844491706820990D+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.00000000000000000D+00, -2.08333333333333333D-01, 4 1.25000000000000000D-01, 3.34201388888888889D-01, 5 -4.01041666666666667D-01, 7.03125000000000000D-02, 6 -1.02581259645061728D+00, 1.84646267361111111D+00, 7 -8.91210937500000000D-01, 7.32421875000000000D-02, 8 4.66958442342624743D+00, -1.12070026162229938D+01, 9 8.78912353515625000D+00, -2.36408691406250000D+00, A 1.12152099609375000D-01, -2.82120725582002449D+01, B 8.46362176746007346D+01, -9.18182415432400174D+01, C 4.25349987453884549D+01, -7.36879435947963170D+00, D 2.27108001708984375D-01, 2.12570130039217123D+02, E -7.65252468141181642D+02, 1.05999045252799988D+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.99579627376132541D+02, 2.18190511744211590D+02, 4 -2.64914304869515555D+01, 5.72501420974731445D-01, 5 -1.91945766231840700D+03, 8.06172218173730938D+03, 6 -1.35865500064341374D+04, 1.16553933368645332D+04, 7 -5.30564697861340311D+03, 1.20090291321635246D+03, 8 -1.08090919788394656D+02, 1.72772750258445740D+00, 9 2.02042913309661486D+04, -9.69805983886375135D+04, A 1.92547001232531532D+05, -2.03400177280415534D+05, B 1.22200464983017460D+05, -4.11926549688975513D+04, C 7.10951430248936372D+03, -4.93915304773088012D+02, D 6.07404200127348304D+00, -2.42919187900551333D+05, E 1.31176361466297720D+06, -2.99801591853810675D+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.76327129765640400D+06, -2.81356322658653411D+06, 4 1.26836527332162478D+06, -3.31645172484563578D+05, 5 4.52187689813627263D+04, -2.49983048181120962D+03, 6 2.43805296995560639D+01, 3.28446985307203782D+06, 7 -1.97068191184322269D+07, 5.09526024926646422D+07, 8 -7.41051482115326577D+07, 6.63445122747290267D+07, 9 -3.75671766607633513D+07, 1.32887671664218183D+07, A -2.78561812808645469D+06, 3.08186404612662398D+05, B -1.38860897537170405D+04, 1.10017140269246738D+02, C -4.93292536645099620D+07, 3.25573074185765749D+08, D -9.39462359681578403D+08, 1.55359689957058006D+09, E -1.62108055210833708D+09, 1.10684281682301447D+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.95889784275030309D+08, 1.42062907797533095D+08, 4 -2.44740627257387285D+07, 2.24376817792244943D+06, 5 -8.40054336030240853D+04, 5.51335896122020586D+02, 6 8.14789096118312115D+08, -5.86648149205184723D+09, 7 1.86882075092958249D+10, -3.46320433881587779D+10, 8 4.12801855797539740D+10, -3.30265997498007231D+10, 9 1.79542137311556001D+10, -6.56329379261928433D+09, A 1.55927986487925751D+09, -2.25105661889415278D+08, B 1.73951075539781645D+07, -5.49842327572288687D+05, C 3.03809051092238427D+03, -1.46792612476956167D+10, D 1.14498237732025810D+11, -3.99096175224466498D+11, E 8.19218669548577329D+11, -1.09837515608122331D+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), 1 C(105)/ 2 1.00815810686538209D+12, -6.45364869245376503D+11, 3 2.87900649906150589D+11, -8.78670721780232657D+10, 4 1.76347306068349694D+10, -2.16716498322379509D+09, 5 1.43157876718888981D+08, -3.87183344257261262D+06, 6 1.82577554742931747D+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.44444444444444444D-03, -9.22077922077922078D-04, 5 -8.84892884892884893D-05, 1.65927687832449737D-04, 6 2.46691372741792910D-04, 2.65995589346254780D-04, 7 2.61824297061500945D-04, 2.48730437344655609D-04, 8 2.32721040083232098D-04, 2.16362485712365082D-04, 9 2.00738858762752355D-04, 1.86267636637545172D-04, A 1.73060775917876493D-04, 1.61091705929015752D-04, B 1.50274774160908134D-04, 1.40503497391269794D-04, C 1.31668816545922806D-04, 1.23667445598253261D-04, D 1.16405271474737902D-04, 1.09798298372713369D-04, E 1.03772410422992823D-04, 9.82626078369363448D-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.32120517249503256D-05, 8.85710852478711718D-05, 5 8.42963105715700223D-05, 8.03497548407791151D-05, 6 7.66981345359207388D-05, 7.33122157481777809D-05, 7 7.01662625163141333D-05, 6.72375633790160292D-05, 8 6.93735541354588974D-04, 2.32241745182921654D-04, 9 -1.41986273556691197D-05, -1.16444931672048640D-04, A -1.50803558053048762D-04, -1.55121924918096223D-04, B -1.46809756646465549D-04, -1.33815503867491367D-04, C -1.19744975684254051D-04, -1.06184319207974020D-04, D -9.37699549891194492D-05, -8.26923045588193274D-05, E -7.29374348155221211D-05, -6.44042357721016283D-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.69611566009369048D-05, -5.04731044303561628D-05, 5 -4.48134868008882786D-05, -3.98688727717598864D-05, 6 -3.55400532972042498D-05, -3.17414256609022480D-05, 7 -2.83996793904174811D-05, -2.54522720634870566D-05, 8 -2.28459297164724555D-05, -2.05352753106480604D-05, 9 -1.84816217627666085D-05, -1.66519330021393806D-05, A -1.50179412980119482D-05, -1.35554031379040526D-05, B -1.22434746473858131D-05, -1.10641884811308169D-05, C -3.54211971457743841D-04, -1.56161263945159416D-04, D 3.04465503594936410D-05, 1.30198655773242693D-04, E 1.67471106699712269D-04, 1.70222587683592569D-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.56501427608594704D-04, 1.36339170977445120D-04, 5 1.14886692029825128D-04, 9.45869093034688111D-05, 6 7.64498419250898258D-05, 6.07570334965197354D-05, 7 4.74394299290508799D-05, 3.62757512005344297D-05, 8 2.69939714979224901D-05, 1.93210938247939253D-05, 9 1.30056674793963203D-05, 7.82620866744496661D-06, A 3.59257485819351583D-06, 1.44040049814251817D-07, B -2.65396769697939116D-06, -4.91346867098485910D-06, C -6.72739296091248287D-06, -8.17269379678657923D-06, D -9.31304715093561232D-06, -1.02011418798016441D-05, E -1.08805962510592880D-05, -1.13875481509603555D-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.17519675674556414D-05, -1.19987364870944141D-05, 5 3.78194199201772914D-04, 2.02471952761816167D-04, 6 -6.37938506318862408D-05, -2.38598230603005903D-04, 7 -3.10916256027361568D-04, -3.13680115247576316D-04, 8 -2.78950273791323387D-04, -2.28564082619141374D-04, 9 -1.75245280340846749D-04, -1.25544063060690348D-04, A -8.22982872820208365D-05, -4.62860730588116458D-05, B -1.72334302366962267D-05, 5.60690482304602267D-06, C 2.31395443148286800D-05, 3.62642745856793957D-05, D 4.58006124490188752D-05, 5.24595294959114050D-05, E 5.68396208545815266D-05, 5.94349820393104052D-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.06478527578421742D-05, 6.08023907788436497D-05, 5 6.01577894539460388D-05, 5.89199657344698500D-05, 6 5.72515823777593053D-05, 5.52804375585852577D-05, 7 5.31063773802880170D-05, 5.08069302012325706D-05, 8 4.84418647620094842D-05, 4.60568581607475370D-05, 9 -6.91141397288294174D-04, -4.29976633058871912D-04, A 1.83067735980039018D-04, 6.60088147542014144D-04, B 8.75964969951185931D-04, 8.77335235958235514D-04, C 7.49369585378990637D-04, 5.63832329756980918D-04, D 3.68059319971443156D-04, 1.88464535514455599D-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.70663057664904149D-05, -8.28520220232137023D-05, 5 -1.72751952869172998D-04, -2.36314873605872983D-04, 6 -2.77966150694906658D-04, -3.02079514155456919D-04, 7 -3.12594712643820127D-04, -3.12872558758067163D-04, 8 -3.05678038466324377D-04, -2.93226470614557331D-04, 9 -2.77255655582934777D-04, -2.59103928467031709D-04, A -2.39784014396480342D-04, -2.20048260045422848D-04, B -2.00443911094971498D-04, -1.81358692210970687D-04, C -1.63057674478657464D-04, -1.45712672175205844D-04, D -1.29425421983924587D-04, -1.14245691942445952D-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.92821964248775885D-03, 1.35592576302022234D-03, 5 -7.17858090421302995D-04, -2.58084802575270346D-03, 6 -3.49271130826168475D-03, -3.46986299340960628D-03, 7 -2.82285233351310182D-03, -1.88103076404891354D-03, 8 -8.89531718383947600D-04, 3.87912102631035228D-06, 9 7.28688540119691412D-04, 1.26566373053457758D-03, A 1.62518158372674427D-03, 1.83203153216373172D-03, B 1.91588388990527909D-03, 1.90588846755546138D-03, C 1.82798982421825727D-03, 1.70389506421121530D-03, D 1.55097127171097686D-03, 1.38261421852276159D-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.20881424230064774D-03, 1.03676532638344962D-03, 3 8.71437918068619115D-04, 7.16080155297701002D-04, 4 5.72637002558129372D-04, 4.42089819465802277D-04, 5 3.24724948503090564D-04, 2.20342042730246599D-04, 6 1.28412898401353882D-04, 4.82005924552095464D-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.79988721413553309D-02, 5.59964911064388073D-03, 5 2.88501402231132779D-03, 1.80096606761053941D-03, 6 1.24753110589199202D-03, 9.22878876572938311D-04, 7 7.14430421727287357D-04, 5.71787281789704872D-04, 8 4.69431007606481533D-04, 3.93232835462916638D-04, 9 3.34818889318297664D-04, 2.88952148495751517D-04, A 2.52211615549573284D-04, 2.22280580798883327D-04, B 1.97541838033062524D-04, 1.76836855019718004D-04, C 1.59316899661821081D-04, 1.44347930197333986D-04, D 1.31448068119965379D-04, 1.20245444949302884D-04, E 1.10449144504599392D-04, 1.01828770740567258D-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.41998224204237509D-05, 8.74130545753834437D-05, 5 8.13466262162801467D-05, 7.59002269646219339D-05, 6 7.09906300634153481D-05, 6.65482874842468183D-05, 7 6.25146958969275078D-05, 5.88403394426251749D-05, 8 -1.49282953213429172D-03, -8.78204709546389328D-04, 9 -5.02916549572034614D-04, -2.94822138512746025D-04, A -1.75463996970782828D-04, -1.04008550460816434D-04, B -5.96141953046457895D-05, -3.12038929076098340D-05, C -1.26089735980230047D-05, -2.42892608575730389D-07, D 8.05996165414273571D-06, 1.36507009262147391D-05, E 1.73964125472926261D-05, 1.98672978842133780D-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.14463263790822639D-05, 2.23954659232456514D-05, 5 2.28967783814712629D-05, 2.30785389811177817D-05, 6 2.30321976080909144D-05, 2.28236073720348722D-05, 7 2.25005881105292418D-05, 2.20981015361991429D-05, 8 2.16418427448103905D-05, 2.11507649256220843D-05, 9 2.06388749782170737D-05, 2.01165241997081666D-05, A 1.95913450141179244D-05, 1.90689367910436740D-05, B 1.85533719641636667D-05, 1.80475722259674218D-05, C 5.52213076721292790D-04, 4.47932581552384646D-04, D 2.79520653992020589D-04, 1.52468156198446602D-04, E 6.93271105657043598D-05, 1.76258683069991397D-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.35744996343269136D-05, -3.17972413350427135D-05, 5 -4.18861861696693365D-05, -4.69004889379141029D-05, 6 -4.87665447413787352D-05, -4.87010031186735069D-05, 7 -4.74755620890086638D-05, -4.55813058138628452D-05, 8 -4.33309644511266036D-05, -4.09230193157750364D-05, 9 -3.84822638603221274D-05, -3.60857167535410501D-05, A -3.37793306123367417D-05, -3.15888560772109621D-05, B -2.95269561750807315D-05, -2.75978914828335759D-05, C -2.58006174666883713D-05, -2.41308356761280200D-05, D -2.25823509518346033D-05, -2.11479656768912971D-05, E -1.98200638885294927D-05, -1.85909870801065077D-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.74532699844210224D-05, -1.63997823854497997D-05, 5 -4.74617796559959808D-04, -4.77864567147321487D-04, 6 -3.20390228067037603D-04, -1.61105016119962282D-04, 7 -4.25778101285435204D-05, 3.44571294294967503D-05, 8 7.97092684075674924D-05, 1.03138236708272200D-04, 9 1.12466775262204158D-04, 1.13103642108481389D-04, A 1.08651634848774268D-04, 1.01437951597661973D-04, B 9.29298396593363896D-05, 8.40293133016089978D-05, C 7.52727991349134062D-05, 6.69632521975730872D-05, D 5.92564547323194704D-05, 5.22169308826975567D-05, E 4.58539485165360646D-05, 4.01445513891486808D-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.50481730031328081D-05, 3.05157995034346659D-05, 5 2.64956119950516039D-05, 2.29363633690998152D-05, 6 1.97893056664021636D-05, 1.70091984636412623D-05, 7 1.45547428261524004D-05, 1.23886640995878413D-05, 8 1.04775876076583236D-05, 8.79179954978479373D-06, 9 7.36465810572578444D-04, 8.72790805146193976D-04, A 6.22614862573135066D-04, 2.85998154194304147D-04, B 3.84737672879366102D-06, -1.87906003636971558D-04, C -2.97603646594554535D-04, -3.45998126832656348D-04, D -3.53382470916037712D-04, -3.35715635775048757D-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.04321124789039809D-04, -2.66722723047612821D-04, 5 -2.27654214122819527D-04, -1.89922611854562356D-04, 6 -1.55058918599093870D-04, -1.23778240761873630D-04, 7 -9.62926147717644187D-05, -7.25178327714425337D-05, 8 -5.22070028895633801D-05, -3.50347750511900522D-05, 9 -2.06489761035551757D-05, -8.70106096849767054D-06, A 1.13698686675100290D-06, 9.16426474122778849D-06, B 1.56477785428872620D-05, 2.08223629482466847D-05, C 2.48923381004595156D-05, 2.80340509574146325D-05, D 3.03987774629861915D-05, 3.21156731406700616D-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.80182191963885708D-03, -2.43402962938042533D-03, 5 -1.83422663549856802D-03, -7.62204596354009765D-04, 6 2.39079475256927218D-04, 9.49266117176881141D-04, 7 1.34467449701540359D-03, 1.48457495259449178D-03, 8 1.44732339830617591D-03, 1.30268261285657186D-03, 9 1.10351597375642682D-03, 8.86047440419791759D-04, A 6.73073208165665473D-04, 4.77603872856582378D-04, B 3.05991926358789362D-04, 1.60315694594721630D-04, C 4.00749555270613286D-05, -5.66607461635251611D-05, D -1.32506186772982638D-04, -1.90296187989614057D-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.32811450376937408D-04, -2.62628811464668841D-04, 5 -2.82050469867598672D-04, -2.93081563192861167D-04, 6 -2.97435962176316616D-04, -2.96557334239348078D-04, 7 -2.91647363312090861D-04, -2.83696203837734166D-04, 8 -2.73512317095673346D-04, -2.61750155806768580D-04, 9 6.38585891212050914D-03, 9.62374215806377941D-03, A 7.61878061207001043D-03, 2.83219055545628054D-03, B -2.09841352012720090D-03, -5.73826764216626498D-03, C -7.70804244495414620D-03, -8.21011692264844401D-03, D -7.65824520346905413D-03, -6.47209729391045177D-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.99132412004966473D-03, -3.45612289713133280D-03, 5 -2.01785580014170775D-03, -7.59430686781961401D-04, 6 2.84173631523859138D-04, 1.10891667586337403D-03, 7 1.72901493872728771D-03, 2.16812590802684701D-03, 8 2.45357710494539735D-03, 2.61281821058334862D-03, 9 2.67141039656276912D-03, 2.65203073395980430D-03, A 2.57411652877287315D-03, 2.45389126236094427D-03, B 2.30460058071795494D-03, 2.13684837686712662D-03, C 1.95896528478870911D-03, 1.77737008679454412D-03, D 1.59690280765839059D-03, 1.42111975664438546D-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.29960524947436582D-01, 2.51984209978974633D-01, 5 1.54790300415655846D-01, 1.10713062416159013D-01, 6 8.57309395527394825D-02, 6.97161316958684292D-02, 7 5.86085671893713576D-02, 5.04698873536310685D-02, 8 4.42600580689154809D-02, 3.93720661543509966D-02, 9 3.54283195924455368D-02, 3.21818857502098231D-02, A 2.94646240791157679D-02, 2.71581677112934479D-02, B 2.51768272973861779D-02, 2.34570755306078891D-02, C 2.19508390134907203D-02, 2.06210828235646240D-02, D 1.94388240897880846D-02, 1.83810633800683158D-02, E 1.74293213231963172D-02, 1.65685837786612353D-02/ DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), 1 GAMA(29), GAMA(30)/ 2 1.57865285987918445D-02, 1.50729501494095594D-02, 3 1.44193250839954639D-02, 1.38184805735341786D-02, 4 1.32643378994276568D-02, 1.27517121970498651D-02, 5 1.22761545318762767D-02, 1.18338262398482403D-02/ DATA EX1, EX2, HPI, GPI, THPI / 1 3.33333333333333333D-01, 6.66666666666666667D-01, 2 1.57079632679489662D+00, 3.14159265358979324D+00, 3 4.71238898038468986D+00/ DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / C RFNU = 1.0D0/FNU C----------------------------------------------------------------------- C OVERFLOW TEST (Z/FNU TOO SMALL) C----------------------------------------------------------------------- TEST = D1MACH(1)*1.0D+3 AC = FNU*TEST IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15 ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU ZETA1I = 0.0D0 ZETA2R = FNU ZETA2I = 0.0D0 PHIR = 1.0D0 PHII = 0.0D0 ARGR = 1.0D0 ARGI = 0.0D0 RETURN 15 CONTINUE ZBR = ZR*RFNU ZBI = ZI*RFNU RFNU2 = RFNU*RFNU C----------------------------------------------------------------------- C COMPUTE IN THE FOURTH QUADRANT C----------------------------------------------------------------------- FN13 = FNU**EX1 FN23 = FN13*FN13 RFN13 = 1.0D0/FN13 W2R = CONER - ZBR*ZBR + ZBI*ZBI W2I = CONEI - ZBR*ZBI - ZBR*ZBI AW2 = ZABS(W2R,W2I) IF (AW2.GT.0.25D0) GO TO 130 C----------------------------------------------------------------------- C POWER SERIES FOR CABS(W2).LE.0.25D0 C----------------------------------------------------------------------- K = 1 PR(1) = CONER PI(1) = CONEI SUMAR = GAMA(1) SUMAI = ZEROI AP(1) = 1.0D0 IF (AW2.LT.TOL) GO TO 20 DO 10 K=2,30 PR(K) = PR(K-1)*W2R - PI(K-1)*W2I PI(K) = PR(K-1)*W2I + PI(K-1)*W2R SUMAR = SUMAR + PR(K)*GAMA(K) SUMAI = SUMAI + PI(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 ZETAR = W2R*SUMAR - W2I*SUMAI ZETAI = W2R*SUMAI + W2I*SUMAR ARGR = ZETAR*FN23 ARGI = ZETAI*FN23 CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI) CALL ZSQRT(W2R, W2I, STR, STI) ZETA2R = STR*FNU ZETA2I = STI*FNU STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI) STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR) ZETA1R = STR*ZETA2R - STI*ZETA2I ZETA1I = STR*ZETA2I + STI*ZETA2R ZAR = ZAR + ZAR ZAI = ZAI + ZAI CALL ZSQRT(ZAR, ZAI, STR, STI) PHIR = STR*RFN13 PHII = STI*RFN13 IF (IPMTR.EQ.1) GO TO 120 C----------------------------------------------------------------------- C SUM SERIES FOR ASUM AND BSUM C----------------------------------------------------------------------- SUMBR = ZEROR SUMBI = ZEROI DO 30 K=1,KMAX SUMBR = SUMBR + PR(K)*BETA(K) SUMBI = SUMBI + PI(K)*BETA(K) 30 CONTINUE ASUMR = ZEROR ASUMI = ZEROI BSUMR = SUMBR BSUMI = SUMBI L1 = 0 L2 = 30 BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI)) ATOL = TOL PP = 1.0D0 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 SUMAR = ZEROR SUMAI = ZEROI DO 40 K=1,KMAX M = L1 + K SUMAR = SUMAR + PR(K)*ALFA(M) SUMAI = SUMAI + PI(K)*ALFA(M) IF (AP(K).LT.ATOL) GO TO 50 40 CONTINUE 50 CONTINUE ASUMR = ASUMR + SUMAR*PP ASUMI = ASUMI + SUMAI*PP IF (PP.LT.TOL) IAS = 1 60 CONTINUE IF (IBS.EQ.1) GO TO 90 SUMBR = ZEROR SUMBI = ZEROI DO 70 K=1,KMAX M = L2 + K SUMBR = SUMBR + PR(K)*BETA(M) SUMBI = SUMBI + PI(K)*BETA(M) IF (AP(K).LT.ATOL) GO TO 80 70 CONTINUE 80 CONTINUE BSUMR = BSUMR + SUMBR*PP BSUMI = BSUMI + SUMBI*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 ASUMR = ASUMR + CONER PP = RFNU*RFN13 BSUMR = BSUMR*PP BSUMI = BSUMI*PP 120 CONTINUE RETURN C----------------------------------------------------------------------- C CABS(W2).GT.0.25D0 C----------------------------------------------------------------------- 130 CONTINUE CALL ZSQRT(W2R, W2I, WR, WI) IF (WR.LT.0.0D0) WR = 0.0D0 IF (WI.LT.0.0D0) WI = 0.0D0 STR = CONER + WR STI = WI CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI) CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM) IF (ZCI.LT.0.0D0) ZCI = 0.0D0 IF (ZCI.GT.HPI) ZCI = HPI IF (ZCR.LT.0.0D0) ZCR = 0.0D0 ZTHR = (ZCR-WR)*1.5D0 ZTHI = (ZCI-WI)*1.5D0 ZETA1R = ZCR*FNU ZETA1I = ZCI*FNU ZETA2R = WR*FNU ZETA2I = WI*FNU AZTH = ZABS(ZTHR,ZTHI) ANG = THPI IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140 ANG = HPI IF (ZTHR.EQ.0.0D0) GO TO 140 ANG = DATAN(ZTHI/ZTHR) IF (ZTHR.LT.0.0D0) ANG = ANG + GPI 140 CONTINUE PP = AZTH**EX2 ANG = ANG*EX2 ZETAR = PP*DCOS(ANG) ZETAI = PP*DSIN(ANG) IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0 ARGR = ZETAR*FN23 ARGI = ZETAI*FN23 CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI) CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI) TZAR = ZAR + ZAR TZAI = ZAI + ZAI CALL ZSQRT(TZAR, TZAI, STR, STI) PHIR = STR*RFN13 PHII = STI*RFN13 IF (IPMTR.EQ.1) GO TO 120 RAW = 1.0D0/DSQRT(AW2) STR = WR*RAW STI = -WI*RAW TFNR = STR*RFNU*RAW TFNI = STI*RFNU*RAW RAZTH = 1.0D0/AZTH STR = ZTHR*RAZTH STI = -ZTHI*RAZTH RZTHR = STR*RAZTH*RFNU RZTHI = STI*RAZTH*RFNU ZCR = RZTHR*AR(2) ZCI = RZTHI*AR(2) RAW2 = 1.0D0/AW2 STR = W2R*RAW2 STI = -W2I*RAW2 T2R = STR*RAW2 T2I = STI*RAW2 STR = T2R*C(2) + C(3) STI = T2I*C(2) UPR(2) = STR*TFNR - STI*TFNI UPI(2) = STR*TFNI + STI*TFNR BSUMR = UPR(2) + ZCR BSUMI = UPI(2) + ZCI ASUMR = ZEROR ASUMI = ZEROI IF (RFNU.LT.TOL) GO TO 220 PRZTHR = RZTHR PRZTHI = RZTHI PTFNR = TFNR PTFNI = TFNI UPR(1) = CONER UPI(1) = CONEI PP = 1.0D0 BTOL = TOL*(DABS(BSUMR)+DABS(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 ZAR = C(L) ZAI = ZEROI DO 150 J=2,KP1 L = L + 1 STR = ZAR*T2R - T2I*ZAI + C(L) ZAI = ZAR*T2I + ZAI*T2R ZAR = STR 150 CONTINUE STR = PTFNR*TFNR - PTFNI*TFNI PTFNI = PTFNR*TFNI + PTFNI*TFNR PTFNR = STR UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI CRR(KS) = PRZTHR*BR(KS+1) CRI(KS) = PRZTHI*BR(KS+1) STR = PRZTHR*RZTHR - PRZTHI*RZTHI PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR PRZTHR = STR DRR(KS) = PRZTHR*AR(KS+2) DRI(KS) = PRZTHI*AR(KS+2) 160 CONTINUE PP = PP*RFNU2 IF (IAS.EQ.1) GO TO 180 SUMAR = UPR(LRP1) SUMAI = UPI(LRP1) JU = LRP1 DO 170 JR=1,LR JU = JU - 1 SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU) SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU) 170 CONTINUE ASUMR = ASUMR + SUMAR ASUMI = ASUMI + SUMAI TEST = DABS(SUMAR) + DABS(SUMAI) IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 180 CONTINUE IF (IBS.EQ.1) GO TO 200 SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR JU = LRP1 DO 190 JR=1,LR JU = JU - 1 SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU) SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU) 190 CONTINUE BSUMR = BSUMR + SUMBR BSUMI = BSUMI + SUMBI TEST = DABS(SUMBR) + DABS(SUMBI) IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1 200 CONTINUE IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 210 CONTINUE 220 CONTINUE ASUMR = ASUMR + CONER STR = -BSUMR*RFN13 STI = -BSUMI*RFN13 CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI) GO TO 120 END SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZUNK1 C***REFER TO ZBESK C C ZUNK1 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 ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS C***END PROLOGUE ZUNK1 C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR EXTERNAL ZABS DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J, M DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / DATA PI / 3.14159265358979324D0 / C KDFLG = 1 NZ = 0 C----------------------------------------------------------------------- C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN C THE UNDERFLOW LIMIT C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) ZRR = ZR ZRI = ZI IF (ZR.GE.0.0D0) GO TO 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE 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 + DBLE(FLOAT(I-1)) INIT(J) = 0 CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), * ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), * CWRKR(1,J), CWRKI(1,J)) IF (KODE.EQ.1) GO TO 20 STR = ZRR + ZETA2R(J) STI = ZRI + ZETA2I(J) RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZETA1R(J) - STR S1I = ZETA1I(J) - STI GO TO 30 20 CONTINUE S1R = ZETA1R(J) - ZETA2R(J) S1I = ZETA1I(J) - ZETA2I(J) 30 CONTINUE RS1 = S1R C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- IF (DABS(RS1).GT.ELIM) GO TO 60 IF (KDFLG.EQ.1) KFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 40 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(PHIR(J),PHII(J)) RS1 = RS1 + DLOG(APHI) IF (DABS(RS1).GT.ELIM) GO TO 60 IF (KDFLG.EQ.1) KFLAG = 1 IF (RS1.LT.0.0D0) 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----------------------------------------------------------------------- S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J) S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J) STR = DEXP(S1R)*CSSR(KFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S1R*S2I + S2R*S1I S2R = STR IF (KFLAG.NE.1) GO TO 50 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 60 50 CONTINUE CYR(KDFLG) = S2R CYI(KDFLG) = S2I YR(I) = S2R*CSRR(KFLAG) YI(I) = S2I*CSRR(KFLAG) IF (KDFLG.EQ.2) GO TO 75 KDFLG = 2 GO TO 70 60 CONTINUE IF (RS1.GT.0.0D0) GO TO 300 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 300 KDFLG = 1 YR(I)=ZEROR YI(I)=ZEROI NZ=NZ+1 IF (I.EQ.1) GO TO 70 IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70 YR(I-1)=ZEROR YI(I-1)=ZEROI NZ=NZ+1 70 CONTINUE I = N 75 CONTINUE RAZR = 1.0D0/ZABS(ZRR,ZRI) STR = ZRR*RAZR STI = -ZRI*RAZR RZR = (STR+STR)*RAZR RZI = (STI+STI)*RAZR CKR = FN*RZR CKI = FN*RZI 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 + DBLE(FLOAT(N-1)) IPARD = 1 IF (MR.NE.0) IPARD = 0 INITD = 0 CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), * CWRKI(1,3)) IF (KODE.EQ.1) GO TO 80 STR = ZRR + ZET2DR STI = ZRI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZET1DR - STR S1I = ZET1DI - STI GO TO 90 80 CONTINUE S1R = ZET1DR - ZET2DR S1I = ZET1DI - ZET2DI 90 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 95 IF (DABS(RS1).LT.ALIM) GO TO 100 C---------------------------------------------------------------------------- C REFINE ESTIMATE AND TEST C------------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) RS1 = RS1+DLOG(APHI) IF (DABS(RS1).LT.ELIM) GO TO 100 95 CONTINUE IF (DABS(RS1).GT.0.0D0) GO TO 300 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 300 NZ = N DO 96 I=1,N YR(I) = ZEROR YI(I) = ZEROI 96 CONTINUE RETURN C--------------------------------------------------------------------------- C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE C---------------------------------------------------------------------------- 100 CONTINUE S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 120 I=IB,N C2R = S2R C2I = S2I S2R = CKR*C2R - CKI*C2I + S1R S2I = CKR*C2I + CKI*C2R + S1I S1R = C2R S1I = C2I CKR = CKR + RZR CKI = CKI + RZI C2R = S2R*C1R C2I = S2I*C1R YR(I) = C2R YI(I) = C2I IF (KFLAG.GE.3) GO TO 120 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 120 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) C1R = CSRR(KFLAG) 120 CONTINUE 160 CONTINUE IF (MR.EQ.0) RETURN C----------------------------------------------------------------------- C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 C----------------------------------------------------------------------- NZ = 0 FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) C----------------------------------------------------------------------- C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. C----------------------------------------------------------------------- CSGNI = SGN INU = INT(SNGL(FNU)) FNF = FNU - DBLE(FLOAT(INU)) IFN = INU + N - 1 ANG = FNF*SGN CSPNR = DCOS(ANG) CSPNI = DSIN(ANG) IF (MOD(IFN,2).EQ.0) GO TO 170 CSPNR = -CSPNR CSPNI = -CSPNI 170 CONTINUE ASC = BRY(1) IUF = 0 KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 270 K=1,N FN = FNU + DBLE(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 172 CONTINUE INITD = INIT(J) PHIDR = PHIR(J) PHIDI = PHII(J) ZET1DR = ZETA1R(J) ZET1DI = ZETA1I(J) ZET2DR = ZETA2R(J) ZET2DI = ZETA2I(J) SUMDR = SUMR(J) SUMDI = SUMI(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 172 INITD = 0 180 CONTINUE CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, * CWRKR(1,M), CWRKI(1,M)) IF (KODE.EQ.1) GO TO 200 STR = ZRR + ZET2DR STI = ZRI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZET1DR + STR S1I = -ZET1DI + STI GO TO 210 200 CONTINUE S1R = -ZET1DR + ZET2DR S1I = -ZET1DI + ZET2DI 210 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 260 IF (KDFLG.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 220 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) RS1 = RS1 + DLOG(APHI) IF (DABS(RS1).GT.ELIM) GO TO 260 IF (KDFLG.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) GO TO 220 IF (KDFLG.EQ.1) IFLAG = 3 220 CONTINUE STR = PHIDR*SUMDR - PHIDI*SUMDI STI = PHIDR*SUMDI + PHIDI*SUMDR S2R = -CSGNI*STI S2I = CSGNI*STR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 230 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.EQ.0) GO TO 230 S2R = ZEROR S2I = ZEROI 230 CONTINUE CYR(KDFLG) = S2R CYI(KDFLG) = S2I C2R = S2R C2I = S2I S2R = S2R*CSRR(IFLAG) S2I = S2I*CSRR(IFLAG) C----------------------------------------------------------------------- C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N C----------------------------------------------------------------------- S1R = YR(KK) S1I = YI(KK) IF (KODE.EQ.1) GO TO 250 CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 250 CONTINUE YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) 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.0D0) GO TO 300 S2R = ZEROR S2I = ZEROI 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----------------------------------------------------------------------- S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) CSR = CSRR(IFLAG) ASCLE = BRY(IFLAG) FN = DBLE(FLOAT(INU+IL)) DO 290 I=1,IL C2R = S2R C2I = S2I S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I FN = FN - 1.0D0 C2R = S2R*CSR C2I = S2I*CSR CKR = C2R CKI = C2I C1R = YR(KK) C1I = YI(KK) IF (KODE.EQ.1) GO TO 280 CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 280 CONTINUE YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI IF (IFLAG.GE.3) GO TO 290 C2R = DABS(CKR) C2I = DABS(CKI) C2M = DMAX1(C2R,C2I) IF (C2M.LE.ASCLE) GO TO 290 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = CKR S2I = CKI S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) CSR = CSRR(IFLAG) 290 CONTINUE RETURN 300 CONTINUE NZ = -1 RETURN END SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZUNK2 C***REFER TO ZBESK C C ZUNK2 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 ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS C***END PROLOGUE ZUNK2 C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR EXTERNAL ZABS DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS 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), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), * CIPI(4), CSSR(3), CSRR(3) DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / 1 0.0D0, 0.0D0, 1.0D0, 1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / DATA HPI, PI, AIC / 1 1.57079632679489662D+00, 3.14159265358979324D+00, 1 1.26551212348464539D+00/ DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), * CIPI(4) / 1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / C KDFLG = 1 NZ = 0 C----------------------------------------------------------------------- C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN C THE UNDERFLOW LIMIT C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) ZRR = ZR ZRI = ZI IF (ZR.GE.0.0D0) GO TO 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE YY = ZRI ZNR = ZRI ZNI = -ZRR ZBR = ZRR ZBI = ZRI INU = INT(SNGL(FNU)) FNF = FNU - DBLE(FLOAT(INU)) ANG = -HPI*FNF CAR = DCOS(ANG) SAR = DSIN(ANG) C2R = HPI*SAR C2I = -HPI*CAR KK = MOD(INU,4) + 1 STR = C2R*CIPR(KK) - C2I*CIPI(KK) STI = C2R*CIPI(KK) + C2I*CIPR(KK) CSR = CR1R*STR - CR1I*STI CSI = CR1R*STI + CR1I*STR IF (YY.GT.0.0D0) GO TO 20 ZNR = -ZNR ZBI = -ZBI 20 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 REAL ON THE POSITIVE REAL AXIS C----------------------------------------------------------------------- J = 2 DO 80 I=1,N C----------------------------------------------------------------------- C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J C----------------------------------------------------------------------- J = 3 - J FN = FNU + DBLE(FLOAT(I-1)) CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), * ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), * ASUMI(J), BSUMR(J), BSUMI(J)) IF (KODE.EQ.1) GO TO 30 STR = ZBR + ZETA2R(J) STI = ZBI + ZETA2I(J) RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZETA1R(J) - STR S1I = ZETA1I(J) - STI GO TO 40 30 CONTINUE S1R = ZETA1R(J) - ZETA2R(J) S1I = ZETA1I(J) - ZETA2I(J) 40 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 70 IF (KDFLG.EQ.1) KFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 50 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(PHIR(J),PHII(J)) AARG = ZABS(ARGR(J),ARGI(J)) RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC IF (DABS(RS1).GT.ELIM) GO TO 70 IF (KDFLG.EQ.1) KFLAG = 1 IF (RS1.LT.0.0D0) GO TO 50 IF (KDFLG.EQ.1) KFLAG = 3 50 CONTINUE C----------------------------------------------------------------------- C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR C EXPONENT EXTREMES C----------------------------------------------------------------------- C2R = ARGR(J)*CR2R - ARGI(J)*CR2I C2I = ARGR(J)*CR2I + ARGI(J)*CR2R CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM) CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMR(J) - DAII*BSUMI(J) STI = DAIR*BSUMI(J) + DAII*BSUMR(J) PTR = STR*CR2R - STI*CR2I PTI = STR*CR2I + STI*CR2R STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J)) STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J)) PTR = STR*PHIR(J) - STI*PHII(J) PTI = STR*PHII(J) + STI*PHIR(J) S2R = PTR*CSR - PTI*CSI S2I = PTR*CSI + PTI*CSR STR = DEXP(S1R)*CSSR(KFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S1R*S2I + S2R*S1I S2R = STR IF (KFLAG.NE.1) GO TO 60 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 70 60 CONTINUE IF (YY.LE.0.0D0) S2I = -S2I CYR(KDFLG) = S2R CYI(KDFLG) = S2I YR(I) = S2R*CSRR(KFLAG) YI(I) = S2I*CSRR(KFLAG) STR = CSI CSI = -CSR CSR = STR IF (KDFLG.EQ.2) GO TO 85 KDFLG = 2 GO TO 80 70 CONTINUE IF (RS1.GT.0.0D0) GO TO 320 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 320 KDFLG = 1 YR(I)=ZEROR YI(I)=ZEROI NZ=NZ+1 STR = CSI CSI =-CSR CSR = STR IF (I.EQ.1) GO TO 80 IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80 YR(I-1)=ZEROR YI(I-1)=ZEROI NZ=NZ+1 80 CONTINUE I = N 85 CONTINUE RAZR = 1.0D0/ZABS(ZRR,ZRI) STR = ZRR*RAZR STI = -ZRI*RAZR RZR = (STR+STR)*RAZR RZI = (STI+STI)*RAZR CKR = FN*RZR CKI = FN*RZI IB = I + 1 IF (N.LT.IB) GO TO 180 C----------------------------------------------------------------------- C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO C ON UNDERFLOW. C----------------------------------------------------------------------- FN = FNU + DBLE(FLOAT(N-1)) IPARD = 1 IF (MR.NE.0) IPARD = 0 CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, * ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI) IF (KODE.EQ.1) GO TO 90 STR = ZBR + ZET2DR STI = ZBI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZET1DR - STR S1I = ZET1DI - STI GO TO 100 90 CONTINUE S1R = ZET1DR - ZET2DR S1I = ZET1DI - ZET2DI 100 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 105 IF (DABS(RS1).LT.ALIM) GO TO 120 C---------------------------------------------------------------------------- C REFINE ESTIMATE AND TEST C------------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) RS1 = RS1+DLOG(APHI) IF (DABS(RS1).LT.ELIM) GO TO 120 105 CONTINUE IF (RS1.GT.0.0D0) GO TO 320 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 320 NZ = N DO 106 I=1,N YR(I) = ZEROR YI(I) = ZEROI 106 CONTINUE RETURN 120 CONTINUE S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 130 I=IB,N C2R = S2R C2I = S2I S2R = CKR*C2R - CKI*C2I + S1R S2I = CKR*C2I + CKI*C2R + S1I S1R = C2R S1I = C2I CKR = CKR + RZR CKI = CKI + RZI C2R = S2R*C1R C2I = S2I*C1R YR(I) = C2R YI(I) = C2I IF (KFLAG.GE.3) GO TO 130 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 130 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) C1R = CSRR(KFLAG) 130 CONTINUE 180 CONTINUE IF (MR.EQ.0) RETURN C----------------------------------------------------------------------- C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 C----------------------------------------------------------------------- NZ = 0 FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) C----------------------------------------------------------------------- C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. C----------------------------------------------------------------------- CSGNI = SGN IF (YY.LE.0.0D0) CSGNI = -CSGNI IFN = INU + N - 1 ANG = FNF*SGN CSPNR = DCOS(ANG) CSPNI = DSIN(ANG) IF (MOD(IFN,2).EQ.0) GO TO 190 CSPNR = -CSPNR CSPNI = -CSPNI 190 CONTINUE 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 REAL ON THE POSITIVE REAL AXIS C----------------------------------------------------------------------- CSR = SAR*CSGNI CSI = CAR*CSGNI IN = MOD(IFN,4) + 1 C2R = CIPR(IN) C2I = CIPI(IN) STR = CSR*C2R + CSI*C2I CSI = -CSR*C2I + CSI*C2R CSR = STR ASC = BRY(1) IUF = 0 KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 290 K=1,N FN = FNU + DBLE(FLOAT(KK-1)) C----------------------------------------------------------------------- C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K C FUNCTION ABOVE C----------------------------------------------------------------------- IF (N.GT.2) GO TO 175 172 CONTINUE PHIDR = PHIR(J) PHIDI = PHII(J) ARGDR = ARGR(J) ARGDI = ARGI(J) ZET1DR = ZETA1R(J) ZET1DI = ZETA1I(J) ZET2DR = ZETA2R(J) ZET2DI = ZETA2I(J) ASUMDR = ASUMR(J) ASUMDI = ASUMI(J) BSUMDR = BSUMR(J) BSUMDI = BSUMI(J) J = 3 - J GO TO 210 175 CONTINUE IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210 IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, * ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, * ASUMDI, BSUMDR, BSUMDI) 210 CONTINUE IF (KODE.EQ.1) GO TO 220 STR = ZBR + ZET2DR STI = ZBI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZET1DR + STR S1I = -ZET1DI + STI GO TO 230 220 CONTINUE S1R = -ZET1DR + ZET2DR S1I = -ZET1DI + ZET2DI 230 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 280 IF (KDFLG.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 240 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) AARG = ZABS(ARGDR,ARGDI) RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC IF (DABS(RS1).GT.ELIM) GO TO 280 IF (KDFLG.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) GO TO 240 IF (KDFLG.EQ.1) IFLAG = 3 240 CONTINUE CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM) CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMDR - DAII*BSUMDI STI = DAIR*BSUMDI + DAII*BSUMDR STR = STR + (AIR*ASUMDR-AII*ASUMDI) STI = STI + (AIR*ASUMDI+AII*ASUMDR) PTR = STR*PHIDR - STI*PHIDI PTI = STR*PHIDI + STI*PHIDR S2R = PTR*CSR - PTI*CSI S2I = PTR*CSI + PTI*CSR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 250 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.EQ.0) GO TO 250 S2R = ZEROR S2I = ZEROI 250 CONTINUE IF (YY.LE.0.0D0) S2I = -S2I CYR(KDFLG) = S2R CYI(KDFLG) = S2I C2R = S2R C2I = S2I S2R = S2R*CSRR(IFLAG) S2I = S2I*CSRR(IFLAG) C----------------------------------------------------------------------- C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N C----------------------------------------------------------------------- S1R = YR(KK) S1I = YI(KK) IF (KODE.EQ.1) GO TO 270 CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 270 CONTINUE YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI STR = CSI CSI = -CSR CSR = STR IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 KDFLG = 1 GO TO 290 255 CONTINUE IF (KDFLG.EQ.2) GO TO 295 KDFLG = 2 GO TO 290 280 CONTINUE IF (RS1.GT.0.0D0) GO TO 320 S2R = ZEROR S2I = ZEROI GO TO 250 290 CONTINUE K = N 295 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----------------------------------------------------------------------- S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) CSR = CSRR(IFLAG) ASCLE = BRY(IFLAG) FN = DBLE(FLOAT(INU+IL)) DO 310 I=1,IL C2R = S2R C2I = S2I S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I FN = FN - 1.0D0 C2R = S2R*CSR C2I = S2I*CSR CKR = C2R CKI = C2I C1R = YR(KK) C1I = YI(KK) IF (KODE.EQ.1) GO TO 300 CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 300 CONTINUE YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI IF (IFLAG.GE.3) GO TO 310 C2R = DABS(CKR) C2I = DABS(CKI) C2M = DMAX1(C2R,C2I) IF (C2M.LE.ASCLE) GO TO 310 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = CKR S2I = CKI S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) CSR = CSRR(IFLAG) 310 CONTINUE RETURN 320 CONTINUE NZ = -1 RETURN END SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, * FNUL, TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZBUNI C***REFER TO ZBESI,ZBESK C C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(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 ZUNI1,ZUNI2,ZABS,D1MACH C***END PROLOGUE ZBUNI C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z EXTERNAL ZABS DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, * D1MACH INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) NZ = 0 AX = DABS(ZR)*1.7321D0 AY = DABS(ZI) IFORM = 1 IF (AY.GT.AX) IFORM = 2 IF (NUI.EQ.0) GO TO 60 FNUI = DBLE(FLOAT(NUI)) DFNU = FNU + DBLE(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 ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, 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 ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, * ELIM, ALIM) 20 CONTINUE IF (NW.LT.0) GO TO 50 IF (NW.NE.0) GO TO 90 STR = ZABS(CYR(1),CYI(1)) C---------------------------------------------------------------------- C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED C---------------------------------------------------------------------- BRY(1)=1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = BRY(2) IFLAG = 2 ASCLE = BRY(2) CSCLR = 1.0D0 IF (STR.GT.BRY(1)) GO TO 21 IFLAG = 1 ASCLE = BRY(1) CSCLR = 1.0D0/TOL GO TO 25 21 CONTINUE IF (STR.LT.BRY(2)) GO TO 25 IFLAG = 3 ASCLE=BRY(3) CSCLR = TOL 25 CONTINUE CSCRR = 1.0D0/CSCLR S1R = CYR(2)*CSCLR S1I = CYI(2)*CSCLR S2R = CYR(1)*CSCLR S2I = CYI(1)*CSCLR RAZ = 1.0D0/ZABS(ZR,ZI) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ DO 30 I=1,NUI STR = S2R STI = S2I S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I S1R = STR S1I = STI FNUI = FNUI - 1.0D0 IF (IFLAG.GE.3) GO TO 30 STR = S2R*CSCRR STI = S2I*CSCRR C1R = DABS(STR) C1I = DABS(STI) C1M = DMAX1(C1R,C1I) IF (C1M.LE.ASCLE) GO TO 30 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1R = S1R*CSCRR S1I = S1I*CSCRR S2R = STR S2I = STI CSCLR = CSCLR*TOL CSCRR = 1.0D0/CSCLR S1R = S1R*CSCLR S1I = S1I*CSCLR S2R = S2R*CSCLR S2I = S2I*CSCLR 30 CONTINUE YR(N) = S2R*CSCRR YI(N) = S2I*CSCRR IF (N.EQ.1) RETURN NL = N - 1 FNUI = DBLE(FLOAT(NL)) K = NL DO 40 I=1,NL STR = S2R STI = S2I S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I S1R = STR S1I = STI STR = S2R*CSCRR STI = S2I*CSCRR YR(K) = STR YI(K) = STI FNUI = FNUI - 1.0D0 K = K - 1 IF (IFLAG.GE.3) GO TO 40 C1R = DABS(STR) C1I = DABS(STI) C1M = DMAX1(C1R,C1I) IF (C1M.LE.ASCLE) GO TO 40 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1R = S1R*CSCRR S1I = S1I*CSCRR S2R = STR S2I = STI CSCLR = CSCLR*TOL CSCRR = 1.0D0/CSCLR S1R = S1R*CSCLR S1I = S1I*CSCLR S2R = S2R*CSCLR S2I = S2I*CSCLR 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 ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, 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 ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, 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 ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZUNI1 C***REFER TO ZBESI,ZBESK C C ZUNI1 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 ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS C***END PROLOGUE ZUNI1 C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, C *S2,Y,Z,ZETA1,ZETA2 EXTERNAL ZABS DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), * CSRR(3), CYR(2), CYI(2) DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / 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----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL C----------------------------------------------------------------------- C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER C----------------------------------------------------------------------- FN = DMAX1(FNU,1.0D0) INIT = 0 CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) IF (KODE.EQ.1) GO TO 10 STR = ZR + ZETA2R STI = ZI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI GO TO 20 10 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 20 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 130 30 CONTINUE NN = MIN0(2,ND) DO 80 I=1,NN FN = FNU + DBLE(FLOAT(ND-I)) INIT = 0 CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) IF (KODE.EQ.1) GO TO 40 STR = ZR + ZETA2R STI = ZI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI + ZI GO TO 50 40 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 50 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 110 IF (I.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 60 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(PHIR,PHII) RS1 = RS1 + DLOG(APHI) IF (DABS(RS1).GT.ELIM) GO TO 110 IF (I.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) GO TO 60 IF (I.EQ.1) IFLAG = 3 60 CONTINUE C----------------------------------------------------------------------- C SCALE S1 IF CABS(S1).LT.ASCLE C----------------------------------------------------------------------- S2R = PHIR*SUMR - PHII*SUMI S2I = PHIR*SUMI + PHII*SUMR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 70 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 110 70 CONTINUE CYR(I) = S2R CYI(I) = S2I M = ND - I + 1 YR(M) = S2R*CSRR(IFLAG) YI(M) = S2I*CSRR(IFLAG) 80 CONTINUE IF (ND.LE.2) GO TO 100 RAST = 1.0D0/ZABS(ZR,ZI) STR = ZR*RAST STI = -ZI*RAST RZR = (STR+STR)*RAST RZI = (STI+STI)*RAST BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = DBLE(FLOAT(K)) DO 90 I=3,ND C2R = S2R C2I = S2I S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I C2R = S2R*C1R C2I = S2I*C1R YR(K) = C2R YI(K) = C2I K = K - 1 FN = FN - 1.0D0 IF (IFLAG.GE.3) GO TO 90 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 90 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) C1R = CSRR(IFLAG) 90 CONTINUE 100 CONTINUE RETURN C----------------------------------------------------------------------- C SET UNDERFLOW AND UPDATE PARAMETERS C----------------------------------------------------------------------- 110 CONTINUE IF (RS1.GT.0.0D0) GO TO 120 YR(ND) = ZEROR YI(ND) = ZEROI NZ = NZ + 1 ND = ND - 1 IF (ND.EQ.0) GO TO 100 CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, 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 + DBLE(FLOAT(ND-1)) IF (FN.GE.FNUL) GO TO 30 NLAST = ND RETURN 120 CONTINUE NZ = -1 RETURN 130 CONTINUE IF (RS1.GT.0.0D0) GO TO 120 NZ = N DO 140 I=1,N YR(I) = ZEROR YI(I) = ZEROI 140 CONTINUE RETURN END SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZUNI2 C***REFER TO ZBESI,ZBESK C C ZUNI2 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 ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS C***END PROLOGUE ZUNI2 C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN EXTERNAL ZABS DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, * CYI, D1MACH, ZABS, CAR, SAR INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, * NN, NUF, NW, NZ, IDUM DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), * CSRR(3), CYR(2), CYI(2) DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ DATA HPI, AIC / 1 1.57079632679489662D+00, 1.265512123484645396D+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----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL C----------------------------------------------------------------------- C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI C----------------------------------------------------------------------- ZNR = ZI ZNI = -ZR ZBR = ZR ZBI = ZI CIDI = -CONER INU = INT(SNGL(FNU)) ANG = HPI*(FNU-DBLE(FLOAT(INU))) C2R = DCOS(ANG) C2I = DSIN(ANG) CAR = C2R SAR = C2I IN = INU + N - 1 IN = MOD(IN,4) + 1 STR = C2R*CIPR(IN) - C2I*CIPI(IN) C2I = C2R*CIPI(IN) + C2I*CIPR(IN) C2R = STR IF (ZI.GT.0.0D0) GO TO 10 ZNR = -ZNR ZBI = -ZBI CIDI = -CIDI C2I = -C2I 10 CONTINUE C----------------------------------------------------------------------- C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER C----------------------------------------------------------------------- FN = DMAX1(FNU,1.0D0) CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) IF (KODE.EQ.1) GO TO 20 STR = ZBR + ZETA2R STI = ZBI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI GO TO 30 20 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 30 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 150 40 CONTINUE NN = MIN0(2,ND) DO 90 I=1,NN FN = FNU + DBLE(FLOAT(ND-I)) CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) IF (KODE.EQ.1) GO TO 50 STR = ZBR + ZETA2R STI = ZBI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI + DABS(ZI) GO TO 60 50 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 60 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 120 IF (I.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 70 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- C----------------------------------------------------------------------- APHI = ZABS(PHIR,PHII) AARG = ZABS(ARGR,ARGI) RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC IF (DABS(RS1).GT.ELIM) GO TO 120 IF (I.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) 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 ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMR - DAII*BSUMI STI = DAIR*BSUMI + DAII*BSUMR STR = STR + (AIR*ASUMR-AII*ASUMI) STI = STI + (AIR*ASUMI+AII*ASUMR) S2R = PHIR*STR - PHII*STI S2I = PHIR*STI + PHII*STR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 80 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 120 80 CONTINUE IF (ZI.LE.0.0D0) S2I = -S2I STR = S2R*C2R - S2I*C2I S2I = S2R*C2I + S2I*C2R S2R = STR CYR(I) = S2R CYI(I) = S2I J = ND - I + 1 YR(J) = S2R*CSRR(IFLAG) YI(J) = S2I*CSRR(IFLAG) STR = -C2I*CIDI C2I = C2R*CIDI C2R = STR 90 CONTINUE IF (ND.LE.2) GO TO 110 RAZ = 1.0D0/ZABS(ZR,ZI) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = DBLE(FLOAT(K)) DO 100 I=3,ND C2R = S2R C2I = S2I S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I C2R = S2R*C1R C2I = S2I*C1R YR(K) = C2R YI(K) = C2I K = K - 1 FN = FN - 1.0D0 IF (IFLAG.GE.3) GO TO 100 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 100 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) C1R = CSRR(IFLAG) 100 CONTINUE 110 CONTINUE RETURN 120 CONTINUE IF (RS1.GT.0.0D0) GO TO 140 C----------------------------------------------------------------------- C SET UNDERFLOW AND UPDATE PARAMETERS C----------------------------------------------------------------------- YR(ND) = ZEROR YI(ND) = ZEROI NZ = NZ + 1 ND = ND - 1 IF (ND.EQ.0) GO TO 110 CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, 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 + DBLE(FLOAT(ND-1)) IF (FN.LT.FNUL) GO TO 130 C FN = CIDI C J = NUF + 1 C K = MOD(J,4) + 1 C S1R = CIPR(K) C S1I = CIPI(K) C IF (FN.LT.0.0D0) S1I = -S1I C STR = C2R*S1R - C2I*S1I C C2I = C2R*S1I + C2I*S1R C C2R = STR IN = INU + ND - 1 IN = MOD(IN,4) + 1 C2R = CAR*CIPR(IN) - SAR*CIPI(IN) C2I = CAR*CIPI(IN) + SAR*CIPR(IN) IF (ZI.LE.0.0D0) C2I = -C2I GO TO 40 130 CONTINUE NLAST = ND RETURN 140 CONTINUE NZ = -1 RETURN 150 CONTINUE IF (RS1.GT.0.0D0) GO TO 140 NZ = N DO 160 I=1,N YR(I) = ZEROR YI(I) = ZEROI 160 CONTINUE RETURN END SUBROUTINE XERROR(MESS,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 INTEGER NMESS, L1, L2, NN, NR, K, I, KMIN CHARACTER*(*) MESS 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*** zqcbes.f C*** machcon.f c----------------------------------------------------------------- C>>> MACHCON.FOR: Machine constants c----------------------------------------------------------------- *DECK I1MACH INTEGER FUNCTION I1MACH(I) C***BEGIN PROLOGUE I1MACH C***DATE WRITTEN 750101 (YYMMDD) C***REVISION DATE 890213 (YYMMDD) C***CATEGORY NO. R1 C***KEYWORDS LIBRARY=SLATEC,TYPE=INTEGER(I1MACH-I),MACHINE CONSTANTS C***AUTHOR FOX, P. A., (BELL LABS) C HALL, A. D., (BELL LABS) C SCHRYER, N. L., (BELL LABS) C***PURPOSE Returns integer machine dependent constants C***DESCRIPTION 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 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 SAVE IMACH EQUIVALENCE (IMACH(4),OUTPUT) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT COMPILER 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)/ -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 APOLLO 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) / 31 / C DATA IMACH(9) / 2147483647 / C DATA IMACH(10)/ 2 / C DATA IMACH(11)/ 24 / C DATA IMACH(12)/ -125 / C DATA IMACH(13)/ 129 / C DATA IMACH(14)/ 53 / C DATA IMACH(15)/ -1021 / C DATA IMACH(16)/ 1025 / 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 170/180 SERIES USING NOS/VE 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) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 9223372036854775807 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -4095 / C DATA IMACH(13) / 4094 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -4095 / C DATA IMACH(16) / 4094 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES 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 CELERITY C1260 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) / Z'7FFFFFFF' / 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 CONVEX C-1 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) / 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) / -128/ C DATA IMACH(13) / 127/ C DATA IMACH(14) / 53/ C DATA IMACH(15) / -1024/ C DATA IMACH(16) / 1023/ 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 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 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 C DATA IMACH(1) / 5 / C DATA IMACH(2) / 6 / C DATA IMACH(3) / 6 / C DATA IMACH(3) / 7 / 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) /-1015 / C 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 IBM PC C DATA IMACH( 1) / 5 / DATA IMACH( 2) / 6 / DATA IMACH( 3) / 0 / DATA IMACH( 4) / 0 / DATA IMACH( 5) / 32 / DATA IMACH( 6) / 4 / DATA IMACH( 7) / 2 / DATA IMACH( 8) / 31 / DATA IMACH( 9) / 2147483647 / DATA IMACH(10) / 2 / DATA IMACH(11) / 24 / DATA IMACH(12) / -125 / DATA IMACH(13) / 127 / DATA IMACH(14) / 53 / DATA IMACH(15) / -1021 / DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 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) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / 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 SILICON GRAPHICS IRIS 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) / 23 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 52 / C DATA IMACH(15) / -1022 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE SUN 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) / 31 / C DATA IMACH(9) /2147483647 / C DATA IMACH(10)/ 2 / C DATA IMACH(11)/ 24 / C DATA IMACH(12)/ -125 / C DATA IMACH(13)/ 128 / C DATA IMACH(14)/ 53 / C DATA IMACH(15)/ -1021 / C DATA IMACH(16)/ 1024 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER C 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 VAX 11/780, G-FLOAT OPTION 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)/ 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 C***FIRST EXECUTABLE STATEMENT I1MACH IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 C I1MACH = IMACH(I) RETURN C 10 CONTINUE WRITE (UNIT = OUTPUT, FMT = 9000) 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') C C CALL FDUMP C C STOP END *DECK R1MACH REAL FUNCTION R1MACH(I) C***BEGIN PROLOGUE R1MACH C***DATE WRITTEN 790101 (YYMMDD) C***REVISION DATE 890213 (YYMMDD) C***CATEGORY NO. R1 C***KEYWORDS LIBRARY=SLATEC,TYPE=SINGLE PRECISION(R1MACH-S D1MACH-D), C MACHINE CONSTANTS C***AUTHOR FOX, P. A., (BELL LABS) C HALL, A. D., (BELL LABS) C SCHRYER, N. L., (BELL LABS) C***PURPOSE Returns 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 C Assume single precision numbers are represented in the T-digit, C base-B form C C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and C EMIN .LE. E .LE. EMAX. C C The values of B, T, EMIN and EMAX are provided in I1MACH as C follows: C I1MACH(10) = B, the base. 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 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 R1MACH(1) - R1MACH(4) should be checked for consistency C with the local operating system. C 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 INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) C REAL RMACH(5) SAVE RMACH C EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7EFFFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE APOLLO C C DATA SMALL(1) / 16#00800000 / C DATA LARGE(1) / 16#7FFFFFFF / C DATA RIGHT(1) / 16#33800000 / C DATA DIVER(1) / 16#34000000 / C DATA LOG10(1) / 16#3E9A209B / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM C C DATA RMACH(1) / Z400800000 / C DATA RMACH(2) / Z5FFFFFFFF / C DATA RMACH(3) / Z4E9800000 / C DATA RMACH(4) / Z4EA800000 / C DATA RMACH(5) / Z500E730E8 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS C C DATA RMACH(1) / O1771000000000000 / C DATA RMACH(2) / O0777777777777777 / C DATA RMACH(3) / O1311000000000000 / C DATA RMACH(4) / O1301000000000000 / C DATA RMACH(5) / O1157163034761675 / C C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE C C DATA RMACH(1) / Z"3001800000000000" / C DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" / C DATA RMACH(3) / Z"3FD2800000000000" / C DATA RMACH(4) / Z"3FD3800000000000" / C DATA RMACH(5) / Z"3FFF9A209A84FBCF" / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C C DATA RMACH(1) / 00564000000000000000B / C DATA RMACH(2) / 37767777777777777776B / C DATA RMACH(3) / 16414000000000000000B / C DATA RMACH(4) / 16424000000000000000B / C DATA RMACH(5) / 17164642023241175720B / C C MACHINE CONSTANTS FOR THE CELERITY C1260 C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE CONVEX C-1 C C DATA SMALL(1) / '00800000'X / C DATA LARGE(1) / '7FFFFFFF'X / C DATA RIGHT(1) / '34800000'X / C DATA DIVER(1) / '35000000'X / C DATA LOG10(1) / '3F9A209B'X / C C MACHINE CONSTANTS FOR THE CRAY-1 C C DATA RMACH(1) / 200034000000000000000B / C DATA RMACH(2) / 577767777777777777776B / C DATA RMACH(3) / 377224000000000000000B / C DATA RMACH(4) / 377234000000000000000B / C DATA RMACH(5) / 377774642023241175720B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC RMACH(5) C C DATA SMALL / 20K, 0 / C DATA LARGE / 77777K, 177777K / C DATA RIGHT / 35420K, 0 / C DATA DIVER / 36020K, 0 / C DATA LOG10 / 40423K, 42023K / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / C DATA LARGE(1), LARGE(2) / '37777777, '00000177 / C DATA RIGHT(1), RIGHT(2) / '20000000, '00000352 / C DATA DIVER(1), DIVER(2) / '20000000, '00000353 / C DATA LOG10(1), LOG10(2) / '23210115, '00000377 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES C C DATA RMACH(1) / O402400000000 / C DATA RMACH(2) / O376777777777 / C DATA RMACH(3) / O714400000000 / C DATA RMACH(4) / O716400000000 / C DATA RMACH(5) / O776464202324 / C C MACHINE CONSTANTS FOR THE HP 2100 C 3 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE91), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE HP 9000 C C DATA SMALL(1) / 00004000000B / C DATA LARGE(1) / 17677777777B / C DATA RIGHT(1) / 06340000000B / C DATA DIVER(1) / 06400000000B / C DATA LOG10(1) / 07646420233B / C C MACHINE CONSTANTS FOR THE ELXSI 6400 C ASSUMING REAL*4 IS THE DEFAULT REAL C C DATA SMALL(1) / '00800000'X / C DATA LARGE(1) / '7F7FFFFF'X / C DATA RIGHT(1) / '33800000'X / C DATA DIVER(1) / '34000000'X / C DATA LOG10(1) / '3E9A209B'X / 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 RMACH(1) / Z00100000 / C DATA RMACH(2) / Z7FFFFFFF / C DATA RMACH(3) / Z3B100000 / C DATA RMACH(4) / Z3C100000 / C DATA RMACH(5) / Z41134413 / C C MACHINE CONSTANTS FOR THE IBM PC C C DATA SMALL(1) / 8420761 / C DATA LARGE(1) / 2139081118 / C DATA RIGHT(1) / 863997169 / C DATA DIVER(1) / 872385777 / C DATA LOG10(1) / 1050288283 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR) C C DATA RMACH(1) / "000400000000 / C DATA RMACH(2) / "377777777777 / C DATA RMACH(3) / "146400000000 / C DATA RMACH(4) / "147400000000 / C DATA RMACH(5) / "177464202324 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1) / 8388608 / C DATA LARGE(1) / 2147483647 / C DATA RIGHT(1) / 880803840 / C DATA DIVER(1) / 889192448 / C DATA LOG10(1) / 1067065499 / C C DATA RMACH(1) / O00040000000 / C DATA RMACH(2) / O17777777777 / C DATA RMACH(3) / O06440000000 / C DATA RMACH(4) / O06500000000 / C DATA RMACH(5) / O07746420233 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1), SMALL(2) / 128, 0 / C DATA LARGE(1), LARGE(2) / 32767, -1 / C DATA RIGHT(1), RIGHT(2) / 13440, 0 / C DATA DIVER(1), DIVER(2) / 13568, 0 / C DATA LOG10(1), LOG10(2) / 16282, 8347 / C C DATA SMALL(1), SMALL(2) / O000200, O000000 / C DATA LARGE(1), LARGE(2) / O077777, O177777 / C DATA RIGHT(1), RIGHT(2) / O032200, O000000 / C DATA DIVER(1), DIVER(2) / O032400, O000000 / C DATA LOG10(1), LOG10(2) / O037632, O020233 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS C c data rmach(1) / 1.17549 424 e-38 / c data rmach(2) / 3.40282 356 e+38 / c data rmach(3) / 1.19209 290 e-07 / c data rmach(4) / 2.38418 579 e-07 / c data rmach(5) / 0.30103 001 / C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'34000000' / C DATA DIVER(1) / Z'34800000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE SUN C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES C C DATA RMACH(1) / O000400000000 / C DATA RMACH(2) / O377777777777 / C DATA RMACH(3) / O146400000000 / C DATA RMACH(4) / O147400000000 / C DATA RMACH(5) / O177464202324 / C C MACHINE CONSTANTS FOR THE VAX 11/780 C (EXPRESSED IN INTEGER AND HEXADECIMAL) C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS C C DATA SMALL(1) / 128 / C DATA LARGE(1) / -32769 / C DATA RIGHT(1) / 13440 / C DATA DIVER(1) / 13568 / C DATA LOG10(1) / 547045274 / C C DATA SMALL(1) / Z00000080 / C DATA LARGE(1) / ZFFFF7FFF / C DATA RIGHT(1) / Z00003480 / C DATA DIVER(1) / Z00003500 / C DATA LOG10(1) / Z209B3F9A / C C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR C C DATA SMALL(1), SMALL(2) / 0, 256/ C DATA LARGE(1), LARGE(2) / -1, -129/ C DATA RIGHT(1), RIGHT(2) / 0, 26880/ C DATA DIVER(1), DIVER(2) / 0, 27136/ C DATA LOG10(1), LOG10(2) / 8347, 32538/ C C C***FIRST EXECUTABLE STATEMENT R1MACH IF (I .LT. 1 .OR. I .GT. 5) 1 CALL XERROR ('R1MACH -- I OUT OF BOUNDS', 25, 1, 2) C R1MACH = RMACH(I) RETURN C END