void
sgefa (float **a, int n, int *ipvt, int *info)
/*****************************************************************************
Gaussian elimination to obtain the LU factorization of a matrix
******************************************************************************
Input:
a matrix[n][n] to be factored (see notes below)
n dimension of a
Output:
a matrix[n][n] factored (see notes below)
ipvt indices of pivot permutations (see notes below)
info index of last zero pivot (or -1 if no zero pivots)
******************************************************************************
Notes:
This function was adapted from LINPACK FORTRAN. Because two-dimensional
arrays cannot be declared with variable dimensions in C, the matrix a
is actually a pointer to an array of pointers to floats, as declared
above and used below.
Elements of a are stored as follows:
a[0][0] a[1][0] a[2][0] ... a[n-1][0]
a[0][1] a[1][1] a[2][1] ... a[n-1][1]
a[0][2] a[1][2] a[2][2] ... a[n-1][2]
. .
. . .
. . .
. .
a[0][n-1] a[1][n-1] a[2][n-1] ... a[n-1][n-1]
Both the factored matrix a and the pivot indices ipvt are required
to solve linear systems of equations via sgesl.
******************************************************************************
Author: Dave Hale, Colorado School of Mines, 10/01/89
*****************************************************************************/
{
int j,k,kp1,l,nm1;
float t;
*info = -1;
nm1 = n-1;
for (k=0; k<nm1; k++) {
kp1 = k+1;
/* find l = pivot index */
l = k+isamax(n-k,&a[k][k],1);
ipvt[k] = l;
/* zero pivot implies this column already triangularized */
if (a[k][l]==0.0) {
*info = k;
continue;
}
/* if necessary, interchange */
if (l!=k) {
t = a[k][l];
a[k][l] = a[k][k];
a[k][k] = t;
}
/* compute multipliers */
t = -1.0/a[k][k];
sscal(n-k-1,t,&a[k][k+1],1);
/* row elimination with column indexing */
for (j=kp1; j<n; j++) {
t = a[j][l];
if (l!=k) {
a[j][l] = a[j][k];
a[j][k] = t;
}
saxpy(n-k-1,t,&a[k][k+1],1,&a[j][k+1],1);
}
}
ipvt[n-1] = n-1;
if (a[n-1][n-1]==0.0) *info = n-1;
}
main()
{
int i,n=N;
printf("isamax = %d\n",isamax(n,sx,1));
printf("isamax = %d\n",isamax(n/2,sx,2));
printf("isamax = %d\n",isamax(n,sy,1));
printf("sasum = %g\n",sasum(n,sx,1));
printf("sasum = %g\n",sasum(n/2,sx,2));
printf("sasum = %g\n",sasum(n,sy,1));
printf("snrm2 = %g\n",snrm2(n,sx,1));
printf("snrm2 = %g\n",snrm2(n/2,sx,2));
printf("snrm2 = %g\n",snrm2(n,sy,1));
printf("sdot = %g\n",sdot(n,sx,1,sy,1));
printf("sdot = %g\n",sdot(n/2,sx,2,sy,2));
printf("sdot = %g\n",sdot(n/2,sx,-2,sy,2));
printf("sdot = %g\n",sdot(n,sy,1,sy,1));
printf("sscal\n");
sscal(n,2.0,sx,1);
pvec(n,sx);
sscal(n,0.5,sx,1);
pvec(n,sx);
sscal(n/2,2.0,sx,2);
pvec(n,sx);
sscal(n/2,0.5,sx,2);
pvec(n,sx);
printf("sswap\n");
sswap(n,sx,1,sy,1);
pvec(n,sx); pvec(n,sy);
sswap(n,sy,1,sx,1);
pvec(n,sx); pvec(n,sy);
sswap(n/2,sx,1,sx+n/2,-1);
pvec(n,sx);
sswap(n/2,sx,1,sx+n/2,-1);
pvec(n,sx);
sswap(n/2,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
sswap(n/2,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
printf("saxpy\n");
saxpy(n,2.0,sx,1,sy,1);
pvec(n,sx); pvec(n,sy);
saxpy(n,-2.0,sx,1,sy,1);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,2.0,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,-2.0,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,2.0,sx,-2,sy,1);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,-2.0,sx,-2,sy,1);
pvec(n,sx); pvec(n,sy);
printf("scopy\n");
scopy(n/2,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
scopy(n/2,sx+1,2,sy+1,2);
pvec(n,sx); pvec(n,sy);
scopy(n/2,sx,2,sy,1);
pvec(n,sx); pvec(n,sy);
scopy(n/2,sx+1,-2,sy+n/2,-1);
pvec(n,sx); pvec(n,sy);
}
int sgefa ( float a[], int lda, int n, int ipvt[] )
/*******************************************************************************/
/*
Purpose:
SGEFA factors a matrix by gaussian elimination.
Discussion:
Matrix references which would, mathematically, be written A(I,J)
must be written here as:
* A[I+J*LDA], when the value is needed, or
* A+I+J*LDA, when the address is needed.
Modified:
07 March 2008
Author:
FORTRAN77 original version by Cleve Moler.
C version by John Burkardt.
Reference:
Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
LINPACK User's Guide,
SIAM, 1979,
ISBN13: 978-0-898711-72-1,
LC: QA214.L56.
Parameters:
Input/output, float A[LDA*N]. On input, the matrix to be factored.
On output, an upper triangular matrix and the multipliers which were
used to obtain it. The factorization can be written A = L * U where
L is a product of permutation and unit lower triangular matrices and
U is upper triangular.
Input, int LDA, the leading dimension of the matrix.
Input, int N, the order of the matrix.
Output, int IPVT[N], the pivot indices.
Output, int SGEFA, indicates singularity.
If 0, this is the normal value, and the algorithm succeeded.
If K, then on the K-th elimination step, a zero pivot was encountered.
The matrix is numerically not invertible.
*/
{
int j;
int info;
int k;
int kp1;
int l;
int nm1;
float t;
info = 0;
for ( k = 1; k <= n - 1; k++ )
{
/*
Find l = pivot index.
*/
l = isamax ( n-k+1, &a[k-1+(k-1)*lda], 1 ) + k - 1;
ipvt[k-1] = l;
/*
Zero pivot implies this column already triangularized.
*/
if ( a[l-1+(k-1)*lda] != 0.0 )
{
/*
Interchange if necessary.
*/
if ( l != k )
{
t = a[l-1+(k-1)*lda];
a[l-1+(k-1)*lda] = a[k-1+(k-1)*lda];
a[k-1+(k-1)*lda] = t;
}
/*
Compute multipliers.
*/
t = - 1.0 / a[k-1+(k-1)*lda];
sscal ( n-k, t, &a[k+(k-1)*lda], 1 );
/*
Row elimination with column indexing.
*/
for ( j = k + 1; j <= n; j++ )
{
t = a[l-1+(j-1)*lda];
if (l != k)
{
a[l-1+(j-1)*lda] = a[k-1+(j-1)*lda];
a[k-1+(j-1)*lda] = t;
}
saxpy ( n-k, t, &a[k+(k-1)*lda], 1, &a[k+(j-1)*lda], 1 );
}
}
else
{
info = k;
}
}
ipvt[n-1] = n;
if (a[n-1+(n-1)*lda] == 0.0 )
{
info = n - 1;
}
return info;
}
int msgefa2 ( float a[], int lda, int n, int ipvt[] )
/******************************************************************************/
/*
Purpose:
MSGEFA2 factors a matrix by gaussian elimination.
Discussion:
Matrix references which would, mathematically, be written A(I,J)
must be written here as:
* A[I+J*LDA], when the value is needed, or
* A+I+J*LDA, when the address is needed.
This variant of SGEFA uses OpenMP for improved parallel execution.
The step in which multiples of the pivot row are added to individual
rows has been replaced by a single call which updates the entire
matrix sub-block.
Modified:
07 March 2008
Author:
FORTRAN77 original version by Cleve Moler.
C version by Wesley Petersen.
Reference:
Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
LINPACK User's Guide,
SIAM, 1979,
ISBN13: 978-0-898711-72-1,
LC: QA214.L56.
Parameters:
Input/output, float A[LDA*N]. On input, the matrix to be factored.
On output, an upper triangular matrix and the multipliers which were
used to obtain it. The factorization can be written A = L * U where
L is a product of permutation and unit lower triangular matrices and
U is upper triangular.
Input, int LDA, the leading dimension of the matrix.
Input, int N, the order of the matrix.
Output, int IPVT[N], the pivot indices.
Output, int MSGEFA, indicates singularity.
If 0, this is the normal value, and the algorithm succeeded.
If K, then on the K-th elimination step, a zero pivot was encountered.
The matrix is numerically not invertible.
*/
{
int info;
int k,kp1,l,nm1;
float t;
info = 0;
nm1 = n - 1;
for ( k = 0; k < nm1; k++ )
{
kp1 = k + 1;
l = isamax ( n-k, a+k+k*lda, 1 ) + k - 1;
ipvt[k] = l + 1;
if ( a[l+k*lda] == 0.0 )
{
info = k + 1;
return info;
}
if ( l != k )
{
t = a[l+k*lda];
a[l+k*lda] = a[k+k*lda];
a[k+k*lda] = t;
}
t = -1.0 / a[k+k*lda];
sscal ( n-k-1, t, a+kp1+k*lda, 1 );
/*
Interchange the pivot row and the K-th row.
*/
if ( l != k )
{
sswap ( n-k-1, a+l+kp1*lda, lda, a+k+kp1*lda, lda );
}
/*
Add multiples of the K-th row to rows K+1 through N.
*/
msaxpy2 ( n-k-1, n-k-1, a+k+kp1*lda, n, a+kp1+k*lda, a+kp1+kp1*lda );
}
ipvt[n-1] = n;
if ( a[n-1+(n-1)*lda] == 0.0 )
{
info = n;
}
return info;
}
int main( int argc, char *argv[] )
{
int ntr=0; /* number of traces */
int ntrv=0; /* number of traces */
int ns=0;
int nsv=0;
float dt;
float dtv;
cwp_String fs;
cwp_String fv;
FILE *fps;
FILE *fpv;
FILE *headerfp;
float *data; /* data matrix of the migration volume */
float *vel; /* velocity matrix */
float *velfi; /* velocity function interpolated to ns values*/
float *velf; /* velocity function */
float *vdt;
float *ddt;
float *ap; /* array of apperture values in m */
float apr; /* array of apperture values in m */
int *apt=NULL; /* array of apperture time limits in mig. gath*/
float r; /* maximum radius with a given apperture */
float ir2; /* r/d2 */
float ir3; /* r/d3 */
float d2; /* spatial sampling int. in dir 2. */
float d3; /* spatial sampling int. in dir 3. */
float **mgd=NULL; /* migration gather data */
float *migt; /* migrated data trace */
int **mgdnz=NULL; /* migration gather data non zero samples*/
float dm; /* migration gather spatial sample int. */
int im; /* number of traces in migration gather */
int *mtnz; /* migrated trace data non zero smaples */
char **dummyi; /* index array that the trace contains zeros only */
float fac; /* velocity scale factor */
int sphr; /* spherical divergence flag */
int imt; /* mute time sample of trace */
float tmp;
int imoff;
int **igtr=NULL;
int nigtr;
int n2;
int n3;
int verbose;
/* phase shift filter stuff */
float power; /* power of i omega applied to data */
float amp; /* amplitude associated with the power */
float arg; /* argument of power */
float phasefac; /* phase factor */
float phase; /* phase shift = phasefac*PI */
complex exparg; /* cexp(I arg) */
register float *rt; /* real trace */
register complex *ct; /* complex transformed trace */
complex *filt; /* complex power */
float omega; /* circular frequency */
float domega; /* circular frequency spacing (from dt) */
float sign; /* sign in front of i*omega default -1 */
int nfft; /* number of points in nfft */
int nf; /* number of frequencies (incl Nyq) */
float onfft; /* 1 / nfft */
size_t nzeros; /* number of padded zeroes in bytes */
initargs(argc, argv);
requestdoc(1);
MUSTGETPARSTRING("fs",&fs);
MUSTGETPARSTRING("fv",&fv);
MUSTGETPARINT("n2",&n2);
MUSTGETPARINT("n3",&n3);
MUSTGETPARFLOAT("d2",&d2);
MUSTGETPARFLOAT("d3",&d3);
if (!getparfloat("dm", &dm)) dm=(d2+d3)/2.0;
/* open datafile */
fps = efopen(fs,"r");
fpv = efopen(fv,"r");
/* Open tmpfile for headers */
headerfp = etmpfile();
/* get information from the first data trace */
ntr = fgettra(fps,&tr,0);
if(n2*n3!=ntr) err(" Number of traces in file %d not equal to n2*n3 %d \n",
ntr,n2*n3);
ns=tr.ns;
if (!getparfloat("dt", &dt)) dt = ((float) tr.dt)/1000000.0;
if (!dt) {
dt = .002;
warn("dt not set, assumed to be .002");
}
/* get information from the first velocity trace */
ntrv = fgettra(fpv,&trv,0);
if(ntrv!=ntr) err(" Number of traces in velocity file %d differ from %d \n",
ntrv,ntr);
nsv=trv.ns;
if (!getparfloat("dtv", &dtv)) dtv = ((float) trv.dt)/1000000.0;
if (!dtv) {
dtv = .002;
warn("dtv not set, assumed to be .002 for velocity");
}
if (!getparfloat("fac", &fac)) fac=2.0;
if (!getparint("verbose", &verbose)) verbose=0;
if (!getparint("sphr", &sphr)) sphr=0;
if (!getparfloat("apr", &apr)) apr=75;
apr*=3.141592653/180;
/* allocate arrays */
data = bmalloc(sizeof(float),ns,ntr);
vel = bmalloc(sizeof(float),nsv,ntr);
velf = ealloc1float(nsv);
velfi = ealloc1float(ns);
migt = ealloc1float(ns);
vdt = ealloc1float(nsv);
ddt = ealloc1float(ns);
ap = ealloc1float(ns);
mtnz = ealloc1int(ns);
dummyi = (char **) ealloc2(n2,n3,sizeof(char));
/* Times to do interpolation of velocity from sparse sampling */
/* to fine sampling of the data */
{ register int it;
for(it=0;it<nsv;it++) vdt[it]=it*dtv;
for(it=0;it<ns;it++) ddt[it]=it*dt;
}
/* Read traces into data */
/* Store headers in tmpfile */
ntr=0;
erewind(fps);
erewind(fpv);
{ register int i2,i3;
for(i3=0;i3<n3;i3++)
for(i2=0;i2<n2;i2++) {
fgettr(fps,&tr);
fgettr(fpv,&trv);
if(tr.trid > 2) dummyi[i3][i2]=1;
else dummyi[i3][i2]=0;
efwrite(&tr, 1, HDRBYTES, headerfp);
bmwrite(data,1,0,i3*n2+i2,ns,tr.data);
bmwrite(vel,1,0,i3*n2+i2,nsv,trv.data);
}
erewind(headerfp);
/* set up the phase filter */
power = 1.0;sign = 1.0;phasefac = 0.5;
phase = phasefac * PI;
/* Set up for fft */
nfft = npfaro(ns, LOOKFAC * ns);
if (nfft >= SU_NFLTS || nfft >= PFA_MAX)
err("Padded nt=%d -- too big", nfft);
nf = nfft/2 + 1;
onfft = 1.0 / nfft;
nzeros = (nfft - ns) * FSIZE;
domega = TWOPI * onfft / dt;
/* Allocate fft arrays */
rt = ealloc1float(nfft);
ct = ealloc1complex(nf);
filt = ealloc1complex(nf);
/* Set up args for complex power evaluation */
arg = sign * PIBY2 * power + phase;
exparg = cexp(crmul(I, arg));
{
register int i;
for (i = 0 ; i < nf; ++i) {
omega = i * domega;
/* kludge to handle omega=0 case for power < 0 */
if (power < 0 && i == 0) omega = FLT_MAX;
/* calculate filter */
amp = pow(omega, power) * onfft;
filt[i] = crmul(exparg, amp);
}
}
/* set up constants for migration */
if(verbose) fprintf(stderr," Setting up constants....\n");
r=0;
for(i3=0;i3<n3;i3++)
for(i2=0;i2<n2;i2++) {
if(dummyi[i3][i2] < 1) {
/* get the velocity function */
bmread(vel,1,0,i3*n2+i2,nsv,velf);
/* linear interpolation from nsv to ns values */
intlin(nsv,vdt,velf,velf[0],velf[nsv-1],ns,ddt,velfi);
/* Apply scale factor to velocity */
{ register int it;
for(it=0;it<ns;it++) velfi[it] *=fac;
}
/* compute maximum radius from apperture and velocity */
{ register int it;
for(it=0;it<ns;it++)
ap[it] = ddt[it]*velfi[it]*tan(apr)/2.0;
}
tmp = ap[isamax(ns,ap,1)];
if(tmp>r) r=tmp;
}
}
r=MIN(r,sqrt(SQR((n2-1)*d2)+SQR((n3-1)*d3)));
ir2 = (int)(2*r/d2)+1;
ir3 = (int)(2*r/d3)+1;
im = (int)(r/dm)+1;
/* allocate migration gather */
mgd = ealloc2float(ns,im);
mgdnz = ealloc2int(ns,im);
apt = ealloc1int(im);
/* set up the stencil for selecting traces */
igtr = ealloc2int(ir2*ir3,2);
stncl(r, d2, d3,igtr,&nigtr);
if(verbose) {
fprintf(stderr," Maximum radius %f\n",r);
fprintf(stderr," Maximum offset %f\n",
sqrt(SQR((n2-1)*d2)+SQR((n3-1)*d3)));
}
/* main processing loop */
for(i3=0;i3<n3;i3++)
for(i2=0;i2<n2;i2++) {
memset( (void *) tr.data, (int) '\0',ns*FSIZE);
if(dummyi[i3][i2] < 1) {
memset( (void *) mgd[0], (int) '\0',ns*im*FSIZE);
memset( (void *) mgdnz[0], (int) '\0',ns*im*ISIZE);
/* get the velocity function */
bmread(vel,1,0,i3*n2+i2,nsv,velf);
/* linear interpolation from nsv to ns values */
intlin(nsv,vdt,velf,velf[0],velf[nsv-1],ns,ddt,velfi);
/* Apply scale factor to velocity */
{ register int it;
for(it=0;it<ns;it++) velfi[it] *=fac;
}
/* create the migration gather */
{ register int itr,ist2,ist3;
for(itr=0;itr<nigtr;itr++) {
ist2=i2+igtr[0][itr];
ist3=i3+igtr[1][itr];
if(ist2 >= 0 && ist2 <n2)
if(ist3 >= 0 && ist3 <n3) {
if(dummyi[ist3][ist2] <1) {
imoff = (int) (
sqrt(SQR(igtr[0][itr]*d2)
+SQR(igtr[1][itr]*d3))/dm+0.5);
bmread(data,1,0,ist3*n2+ist2,ns,tr.data);
imoff=MIN(imoff,im-1);
{ register int it;
/* get the mute time for this
offset, apperture and velocity */
xindex(ns,ap,imoff*dm,&imt);
for(it=imt;it<ns;it++)
if(tr.data[it]!=0) {
mgd[imoff][it]+=tr.data[it];
mgdnz[imoff][it]+=1;
}
}
}
}
}
}
/* normalize the gather */
{ register int ix,it;
for(ix=0;ix<im;ix++)
for(it=0;it<ns;it++)
if(mgdnz[ix][it] > 1) mgd[ix][it] /=(float) mgdnz[ix][it];
}
memset( (void *) tr.data, (int) '\0',ns*FSIZE);
memset( (void *) mtnz, (int) '\0',ns*ISIZE);
/* do a knmo */
{ register int ix,it;
for(ix=0;ix<im;ix++) {
/* get the mute time for this
offset, apperture and velocity */
xindex(ns,ap,ix*dm,&imt);
knmo(mgd[ix],migt,ns,velfi,0,ix*dm,dt,imt,sphr);
/* stack the gather */
for(it=0;it<ns;it++) {
if(migt[it]!=0.0) {
tr.data[it] += migt[it];
mtnz[it]++;
}
/* tr.data[it] += mgd[ix][it]; */
}
}
}
{ register int it;
for(it=0;it<ns;it++)
if(mtnz[it]>1) tr.data[it] /=(float)mtnz[it];
}
/*Do the phase filtering before the trace is released*/
/* Load trace into rt (zero-padded) */
memcpy( (void *) rt, (const void *) tr.data, ns*FSIZE);
memset((void *) (rt + ns), (int) '\0', nzeros);
pfarc(1, nfft, rt, ct);
{ register int i;
for (i = 0; i < nf; ++i) ct[i] = cmul(ct[i], filt[i]);
}
pfacr(-1, nfft, ct, rt);
memcpy( (void *) tr.data, (const void *) rt, ns*FSIZE);
} /* end of dummy if */
/* spit out the gather */
efread(&tr, 1, HDRBYTES, headerfp);
puttr(&tr);
if(verbose) fprintf(stderr," %d %d\n",i2,i3);
} /* end of i2 loop */
} /* end of i3 loop */
/* This should be the last thing */
efclose(headerfp);
/* Free memory */
free2int(igtr);
free2float(mgd);
free2int(mgdnz);
free1int(apt);
bmfree(data);
bmfree(vel);
free1float(velfi);
free1float(velf);
free1float(ddt);
free1float(vdt);
free1float(ap);
free1int(mtnz);
free1float(migt);
free1float(rt);
free1complex(ct);
free1complex(filt);
free2((void **) dummyi);
return EXIT_SUCCESS;
}
