Sindbad~EG File Manager
/*
9.24.92
Adapted by M. Beeson by extensive modification from:
Bessel functions for complex arguments
from C Mathematical Function Handbook by Louis Baker,
which was in turn based upon the FORTRAN subroutine
BESSEL by R. C. Lindberg
published in Math Note 1 by Air Force Weapons Lab.
Kirtland AFB, NM (now Phillips Lab.)
Baker's code handled errors poorly, did not compute Cabs
carefully to avoid overflow, and worst of all, did not free the
malloc'd memory, so it crashed soon after starting a contour plot of J0
11.18.93 added heap.h and changed malloc to mallocate, free to free2
5.31.94 changed mallocate to alloca, eliminating the need for free2,
and making it possible to use this as part of deval.dll without any heap.
1.7.97 replaced abs by fabs to avoid warnings in VC
9.20.97 added export.h
5.4.13 changed malloc.h to stdlib.h
*/
/*
bessel returns bessel functions and derivatives for complex arguments,
integer orders.
dcomplex cbesselj(int n, double z);
ibess In(z) complex z integer n
kbess Kn(z) complex z integer n
cbess lowest order functions calculated
*/
#include <math.h>
#ifdef XCODE
#include <stdlib.h> /* alloca */
#else
#include <malloc.h>
#endif
#include "dcomplex.h"
#include "baker.h"
#define PI_DECIMAL 3.141592653589793238462643383279
#define errorcode -1.e60
#define limit 1.e-8
#define big ( - ( errorcode ) )
static int cbess( dcomplex *z,dcomplex *j0,dcomplex *j1,
dcomplex *y0,dcomplex *y1,
dcomplex *h20,dcomplex *h21
);
static int bessel(int nn,dcomplex *z,dcomplex *j,dcomplex *y,dcomplex *h2,
dcomplex *jprime,dcomplex *yprime,dcomplex *h2prime
);
static int backward(dcomplex *z,dcomplex *ratio,int idim);
static int forward(dcomplex *z,dcomplex *ratio,int idim, dcomplex *r1);
extern void nospace(void);
static dcomplex ci = { 0.0, 1.0};
/*__________________________________________________________________*/
dcomplex Cbessi(int n,dcomplex z)
{ dcomplex zz,j,dummy,mult,ans;
double theta;
int err;
theta=atan2(z.i,z.r);
CMULT(zz,z,ci);
err = bessel(n,&zz,&j,&dummy,&dummy,&dummy,&dummy,&dummy);
if(err || fabs(j.r)==fabs(errorcode))
return badval;
ans = j;
if(theta <= PI_DECIMAL*.5 ||theta> PI_DECIMAL)
{
CTREAL(dummy,ci, -PI_DECIMAL*.5*n);
mult = Cexp(dummy);
CMULT(ans,ans,mult);
return ans;
}
/*else*/
CTREAL(dummy,ci, PI_DECIMAL*1.5*n);
mult = Cexp(dummy);
CMULT(ans,ans,mult);
return ans;
}
/*_______________________________________________________________________*/
dcomplex Cbessk(int n, dcomplex z)
{ dcomplex j,y,h1,h2,zz,mult,dummy;
double theta;
dcomplex ans;
int err;
theta=atan2(z.i,z.r);
if(theta <= PI_DECIMAL*.5 ||theta> PI_DECIMAL)
{
CMULT(zz,z,ci);
err = bessel(n,&zz,&j,&y,&h2,&dummy,&dummy,&dummy);
if(err || fabs(y.r)==fabs(errorcode))
return badval;
CMULT(dummy,ci,y);
CADD(h1,j,dummy);
CTREAL(dummy,ci, PI_DECIMAL*.5*n);
mult = Cexp(dummy);
CMULT(dummy,h1,mult);
CMULT(ans,dummy,ci);
CTREAL(ans,ans, PI_DECIMAL*.5);
return ans;
}
/*else*/
CMULT(zz,z,ci);
CTREAL(zz,zz,-1.);
err = bessel(n,&zz,&j,&y,&h2,&dummy,&dummy,&dummy);
if( err || fabs(h2.r)==fabs(errorcode))
return badval;
CMULT(ans,h2,ci);
CTREAL(dummy,ci, -PI_DECIMAL*.5*n);
mult = Cexp(dummy);
CMULT(dummy,h2,mult);
CMULT(ans,dummy,ci);
CTREAL(ans,ans,-PI_DECIMAL*.5);
return ans;
}
/*_______________________________________________________________*/
dcomplex Cbessy(int n, dcomplex x)
{ int err;
dcomplex dummy,ans;
err = bessel(n,&x,&dummy,&ans,&dummy,&dummy,&dummy,&dummy);
if(err)
return badval;
return ans;
}
/*_______________________________________________________________*/
dcomplex Cbessj(int n, dcomplex x)
{ int err;
dcomplex dummy,ans;
err = bessel(n,&x,&ans,&dummy,&dummy,&dummy,&dummy,&dummy);
if(err)
return badval;
return ans;
}
/*_______________________________________________________________*/
#if 0 // this function is unused
double baker_besselj(int n,double z)
{ dcomplex x,dummy,ans;
int err;
x.r=z;x.i=0.;
err = bessel(n,&x,&ans,&dummy,&dummy,&dummy,&dummy,&dummy);
if(err)
ans = badval;
return ans.r;
}
#endif
/*____________________________________________________________*/
static int bessel(int nn,dcomplex *z,dcomplex *j,dcomplex *y,dcomplex *h2,
dcomplex *jprime,dcomplex *yprime,dcomplex *h2prime
)
/* return value 0 is success, nonzero is error */
/* Simultaneously computes Jn(z), Yn(z), Jn'(z), Yn'(z) */
{
dcomplex p,q,c1,c0,cb,jz,j1,yz,y1,hz,h1,r1,aux1,aux2;
dcomplex *b,*fy,*fh,noverz;
/*dcomplex b[1000];*/
int i,iret,err,idim,n;
n=nn;
CMPLX(c0,0.,0.);
CMPLX(c1,1.,0.);
/*CMPLX(cb,1.e10,0.);*/
CMPLX(cb, fabs(errorcode) ,0.);
iret=0;
if(n<0)
{ n=-n;
iret=1;
}
if(n<=1)
{ err = cbess(z,&jz,&j1,&yz,&y1,&hz,&h1);
if(err)
return 1;
if(n==1)
{ *j = j1;
*y = y1;
*h2 = h1;
if(Cabs(*z)!=0.)
{ CDIV(p,c1,*z);
CMULT(q,p,j1);
CSUB(*jprime,jz,q);
CMULT(q,p,y1);
CSUB(*yprime,yz,q);
CMULT(q,p,h1);
CSUB(*h2prime,hz,q);
if(iret)
{
if( !(n-((n>>1)<<1)) )
return 0;
CTREAL((*j),(*j),-1.);
CTREAL((*y),(*y),-1.);
CTREAL((*h2),(*h2),-1.);
CTREAL((*jprime),(*jprime),-1.);
CTREAL((*yprime),(*yprime),-1.);
CTREAL((*h2prime),(*h2prime),-1.);
}
return 0;
}
CMPLX(*jprime,0.,0.);
CMPLX(*yprime,0.,0.);
CMPLX(*h2prime,0.,0.);
return 0;
}
/*n=0*/
*j = jz;
*y = yz;
*h2 = hz;
CSUB(*jprime,c0,j1);
CSUB(*yprime,c0,y1);
CSUB(*h2prime,c0,h1);
return 0;
}
if(Cabs(*z)==0.)
{ *j = c0;
*jprime = c0;
*y = cb;
CTREAL(*y,*y,-1.);
*h2 = cb;
*yprime = cb;
*h2 =cb;
CTREAL(*h2prime,*h2prime,-1.)
return 0;
}
CDIV(p,c1,*z);
CTREAL(noverz,p,((double)n));
err = cbess(z,&jz,&j1,&yz,&y1,&hz,&h1);
if(err)
return 1;
*j = jz;
/* set up via malloc b array of idim length*/
idim=20*n;
b = alloca( sizeof( dcomplex) *idim+50*8);
backward(z,b,idim);
for(i=0;i<n;i++)
{ CMULT(p,*j,(b[i]));
*j = p;
}
CSUB(q,noverz,(b[n]));
CMULT((*jprime),q,(*j));
CDIV(r1,y1,yz);
idim=n+2;
fy = alloca( sizeof(dcomplex) *idim+50*8);
forward(z,fy,idim,&r1);
*y = yz;
for(i=0;i<n;i++)
{ CMULT(p,(*y),(fy[i]));
*y = p;
}
CSUB(q,noverz,fy[n]);
CMULT(*yprime,q,*y);
CDIV(r1,y1,yz);
if( z->i == 0.0)
{ CMULT(q,ci,*y);
CSUB(*h2,*j,q);
CMULT(q,yz,fy[n]);
CMULT(aux2,q,ci);
CMULT(p,jz,b[n]);
CSUB(q,p,aux2);
CMULT(aux1,noverz,*h2);
CSUB((*h2prime),aux1,q);
}
else
{
CDIV(r1,h1,hz);
idim=n+2;
fh= alloca( sizeof(dcomplex) *idim+8*50);
forward(z,fh,idim,&r1);
*h2 = hz;
for(i=0;i<n;i++)
{ CMULT(q,*h2,fh[i]);
*h2 = q;
}
CMULT(p,noverz,(*h2));
CMULT(q,(*h2),fh[n]);
CSUB((*h2prime),p,q);
/* free2(fh); */
if(iret)
{ if( !(n-((n>>1)<<1)) )
return 0;
CTREAL((*j),(*j),-1.);
CTREAL((*y),(*y),-1.);
CTREAL((*h2),(*h2),-1.);
CADD(q,noverz,b[n]);
CMULT((*jprime),q,(*j));
CADD(q,noverz,fy[n]);
CMULT((*yprime),q,(*y));
CMULT(q,ci,(*yprime));
CSUB((*h2prime),(*j),q);
}
}
/* free2(b); */
/* free2(fy); */
return 0;
}
/*_______________________________________________________*/
static dcomplex wronsk;
static int cbess(dcomplex *z,dcomplex *j0,dcomplex *j1,dcomplex *y0,dcomplex *y1,
dcomplex *h20,dcomplex *h21)
/* compute Bessel functions of order 0 and 1 */
/* return 0 for success, 1 for error */
{
dcomplex p,q,zsq,fact,zfact,j0add,j1add,ez,aux1,aux2,aux,cosp,sinp,
cii,c1;
double skinv, fk,fn,fkfact,fkfi,tol=1.e-8,u,tolz=1.e-8,tolw=1.e-8;
int phase;
CMPLX(cii,1.,1.);
CMPLX(c1,1.,0.);
if( Cabs(*z)<= 10.)
{
CMPLX(*j0,1.,0.);
CMPLX(*j1,1.,0.);
CMPLX(*y0,0.,0.);
CMPLX(*y1,1.,0.);
CMULT(p,*z,*z);
CTREAL(zsq,p,-.25);
fk=1.;
fkfact=1.;
CMPLX(zfact,1.,0.);
skinv=1.;
do
{/*series*/
CMULT(p,zfact,zsq);
zfact = p;
fkfi=1./fkfact;
CTREAL(fact,zfact,fkfi);
CTREAL(j0add,fact,fkfi);
fk+=1.;
fkfact*=fk;
fkfi=1./fkfact;
CTREAL(j1add,fact,fkfi);
CADD(*j0,*j0,j0add);
CADD(*j1,*j1,j1add);
CTREAL(p,j0add,skinv);
CADD(*y0,*y0,p);
CTREAL(p,j1add, (skinv+skinv+1./fk));
CADD(*y1,*y1,p);
skinv+=1./fk;
}while(Cabs(j1add)>Cabs(*j0)*tol || Cabs(j1add)>Cabs(*j1)*tol);
CMULT(p,*j1,*z);
CTREAL(*j1,p,.5);
if(Cabs(*z)< tolz)
{
CMPLX(*y0,-big,0.)
CMPLX(*y1,-big,0.);
CMPLX(*h20,big,0.);
CMPLX(*h21,big,0.);
return 0;
}
CTREAL(p,*z,.5);
q = Cln(p);
q.r+=.5772156649;
fkfi=1./1.570796326795;
CMULT(p,q,*j0);
CSUB(*y0,p,*y0);
CTREAL(*y0,*y0,fkfi);
CMULT(p,q,*j1);
CMULT(aux1,*y1,zsq);
CSUB(aux2,c1,aux1);
CDIV(aux1,aux2,*z);
CSUB(q,p,aux1);
CTREAL(*y1,q,fkfi);
CMULT(aux1,ci,*y0);
CSUB(*h20,*j0,aux1);
CMULT(aux1,ci,*y1);
CSUB(*h21,*j1,aux1);
goto wronskian;
}
/*else*/
if( fabs(z->i)<1.e-9 && z->r < 0.)
{
phase=1;
z->r = -(z->r);
}
else
phase=0;
/* above added to handle phase= PI_DECIMAL, ie z real <0 */
CTREAL(ez,*z,8.);
CTREAL(fact,*z,PI_DECIMAL);
aux = Csqrt(fact);
CDIV(fact,c1,aux);
Ctrig(*z,&aux1,&aux2);
CMULT(cosp,aux1,fact);
CMULT(sinp,aux2,fact);
CMULT(aux1,*z,ci);
CTREAL(aux1,aux1,-1.);
aux = Cexp(aux1);
CMULT(aux1,aux,fact);
CMULT(zfact,aux1,cii);
u=0.;
retry:
fn=1.;
fk=1.;
CMPLX(p,1.,0.);
CMPLX(aux, (u-1.),0.);
CDIV(q,aux,ez);
fact = q;
do
{ fn+=2.;
fk+=1.;
CTREAL(aux,fact, -(u-fn*fn)/fk);
CDIV(fact,aux,ez);
CADD(p,p,fact);
fn+=2.;
fk+=1.;
CTREAL(aux,fact, (u-fn*fn)/fk);
CDIV(fact,aux,ez);
CADD(q,q,fact);
} while(fk<21. && Cabs(fact)>Cabs(q)*tol);
if( u <=0.)
{ CADD(aux1,p,q);
CSUB(aux2,p,q);
CMULT(aux,aux1,cosp);
CMULT(fact,aux2,sinp);
CADD(*j0,aux,fact);
CMULT(aux,aux1,sinp);
CMULT(fact,aux2,cosp);
CSUB(*y0,aux,fact);
CMULT(aux,ci,q);
CSUB(aux,p,aux);
CMULT(*h20,aux,zfact);
u=4.;
goto retry;
}
CADD(aux1,p,q);
CSUB(aux2,p,q);
CMULT(aux,aux1,sinp);
CMULT(fact,aux2,cosp);
CSUB(*j1,aux,fact);
CMULT(aux,aux1,cosp);
CMULT(fact,aux2,sinp);
CADD(*y1,aux,fact);
CTREAL(*y1,*y1,-1.);
CMULT(aux,ci,q);
CADD(aux,p,aux);
CMULT(*h21,aux,zfact);
if(phase)
{ z->r = -(z->r);
CMULT(p,*j0,ci);
CTREAL(p,p,2.);
CADD( *y0,*y0,p);
CMULT(p,*y0,ci);
CSUB(*h20,*j0,p);
CTREAL(*j1,*j1,-1.);
CMULT(p,*j1,ci);
CTREAL(p,p,2.);
CSUB(*y1,p,*y1);
CMULT(p,*y1,ci);
CSUB(*h21,*j1,p);
}
wronskian:
/*wronskian*/
if( Cabs(*z)<tolz)
return 0;
CDIV(aux,c1,*z);
CTREAL(aux,aux,2./PI_DECIMAL);
CMULT(p,*j1,*y0);
CMULT(q,*j0,*y1);
CADD(q,q,aux);
CDIV(wronsk,p,q);
CSUB(wronsk,wronsk,c1);/* should be zero*/
if(Cabs(wronsk)>tolw)
return 1;
return 0;
}
/*_______________________________________________________________________*/
static int forward(dcomplex *z,dcomplex *ratio,int idim, dcomplex *r1)
{
dcomplex p,twooz,two,c1;
int i,imax;
two.r=2.;two.i=0.;
c1.r=1.;c1.i=0.;
imax=idim-1;
CDIV(twooz, two,(*z));
CASSN((ratio[0]),r1);
for (i=0;i<imax;i++)
{ CMULT(p,(ratio[i]),twooz );
CTREAL(p,p,(double)(i+1));
CSUB(p,p,c1);
CDIV((ratio[i+1]),p,(ratio[i]));
}
return 0;
}
/*______________________________________________________________*/
static int backward(dcomplex *z,dcomplex *ratio,int idim)
{
dcomplex p,denom,twooz,two,c1;
int j,i;
two.r=2.;
two.i=0.;
c1.r=1.;
c1.i=0.;
CDIV(twooz, two,(*z) );
for(j=0;j<idim;j++)
{ CMPLX(ratio[j],0.,0.);
}
CTREAL(denom,*z,.5/(idim));
ratio[idim-1]=denom;
for(i=idim-2;i>=0;i--)
{ CTREAL(p,twooz, (double)(i+1) );
CSUB(denom ,p ,ratio[i+1]);
if( Cabs(denom)>limit)
{ CDIV((ratio[i]),c1,denom);
}
else
{ CMPLX((ratio[i]),big,0. );
}
}
return 0;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists