/* allocate a 1-d array of ints */
int *ealloc1int(size_t n1)
{
int *p;
if (ERROR == (p=alloc1int(n1)))
syssuerr("%s: malloc failed", __FILE__);
return p;
}
/*************************************************************************
Subroutine to multiply the inverse of a square matrix and
by another matrix without computing the inverse
*************************************************************************/
void inverse_matrix_multiply (int nrows1, float **matrix1, int ncols2,
int nrows2, float **matrix2, float **out_matrix)
/*************************************************************************
Input Parameters:
nrows1 number of rows (and columns) of matrix to invert
matrix1 square matrix to invert
ncols2 number of coulmns of second matrix
nrows2 number of rows of second matrix
matrix second matrix (multiplicator)
Output Parameters:
out_matrix matrix containing the product of the inverse of the first
matrix by the second one.
Note:
matrix1 and matrix2 are not destroyed (not clobbered)
*************************************************************************
Credits:
Adapted from discussions in Numerical Recipes in C by Gabriel Alvarez (1995)
*************************************************************************/
{
int i,j; /* loop counters for rows and coulmns */
float d; /* to use in LU decomposition */
int *idx; /* to record permutations by partial pivoting*/
float **scratch1; /* array to hold input matrix1 */
float *scratch2; /* vector to hold column of input matrix2 */
/* allocate working space */
idx = alloc1int(nrows1);
scratch1 = alloc2float(nrows1,nrows1);
scratch2 = alloc1float(nrows2);
/* copy input matrix1 to scratch to avoid clobbering */
for (i=0; i<nrows1; i++)
for (j=0; j<nrows1; j++)
scratch1[i][j]=matrix1[i][j];
/* do the LU decomposition */
LU_decomposition (nrows1, scratch1, idx, &d);
/* find inverse by columns */
for (j=0; j<ncols2; j++) {
/* copy column of second input matrix to scratch vector */
for (i=0; i<nrows2; i++) scratch2[i]=matrix2[i][j];
/* do backward substitution */
backward_substitution (nrows1, scratch1, idx, scratch2);
/* copy results to output matrix */
for (i=0; i<nrows1; i++) out_matrix[i][j] = scratch2[i];
}
/* free allocated space */
free2float(scratch1);
free1float(scratch2);
}
/************************************************************************
Subroutine to invert a square non-singular matrix via LU
decomposition. The original matrix is clobbered with the inverse
************************************************************************/
void inverse_matrix (int nrows, float **matrix)
/************************************************************************
Input:
nrows number of rows (and columns) in matrix to invert
matrix square, non-singular matrix to invert
Output:
matrix inverted matrix
************************************************************************
Credits:
Adapted from discussions in Numerical Recipes by Gabriel Alvarez (1995)
************************************************************************/
{
int i,j; /* loop counters */
float d; /* +/-1 depending on row interchanges even/odd*/
int *idx; /* vector of row permutations */
float *column; /* unit vector for backward substitution*/
float **inverse; /* array to hold the inverse matrix */
/* allocate working space */
idx = alloc1int(nrows);
column = alloc1float(nrows);
inverse = alloc2float(nrows,nrows);
/* first, do the LU decomposition of input matrix */
LU_decomposition (nrows, matrix, idx, &d);
/* find inverse by columns */
for (j=0; j<nrows; j++) {
/* unit vector corresponding to current column */
for (i=0; i<nrows; i++) column[i]=0.0;
column[j]=1.0;
/* backward substitution column by column */
backward_substitution (nrows, matrix, idx, column);
/* compute inverse matrix column by column */
for (i=0; i<nrows; i++)
inverse[i][j]=column[i];
}
/* clobber original matrix with its inverse */
for (i=0; i<nrows; i++)
for (j=0; j<nrows; j++)
matrix[i][j]=inverse[i][j];
/* free allocated space */
free1int(idx);
free1float(column);
free2float(inverse);
}
/* the main program */
int main (int argc, char **argv)
{
double vp1,vp2,vs1,vs2,rho1,rho2;
double eps1,eps2,delta1,delta2;
double gamma1,gamma2,azimuth;
float fangle,langle,dangle,angle;
double *coeff,p=0;
double sangle,cangle,sazi,cazi;
float anglef,dummy;
FILE *outparfp=NULL, *coeffp=NULL;
int ibin,modei,modet,rort,iangle,iscale,index;
char *outparfile=NULL,*coeffile=NULL;
Stiff2D *spar1, *spar2;
double **a,*rcond,*z;
int *ipvt;
/* allocate space for stiffness elements */
spar1=(Stiff2D*)emalloc(sizeof(Stiff2D));
spar2=(Stiff2D*)emalloc(sizeof(Stiff2D));
/* allocate space for matrix system */
a = alloc2double(6,6);
coeff = alloc1double(6);
ipvt=alloc1int(6);
z = alloc1double(6);
rcond=alloc1double(6);
/* hook up getpar to handle the parameters */
initargs(argc,argv);
requestdoc(0);
if (!getparint("ibin",&ibin)) ibin = 1;
if (!getparint("modei",&modei)) modei = 0;
if (!getparint("modet",&modet)) modet = 0;
if (!getparint("rort",&rort)) rort = 1;
if (!getparint("iscale",&iscale)) iscale = 0;
if (!getparint("test",&test)) test = 1;
if (!getparint("info",&info)) info = 0;
if(modei != 0 && modei !=1 && modei !=2){
fprintf(stderr," \n ERROR wrong incidence mode \n");
return (-1); /* wrong mode */
}
if(modet != 0 && modet !=1 && modet !=2){
fprintf(stderr," \n ERROR wrong scattering mode \n");
return (-1); /* wrong mode */
}
if(rort != 0 && rort !=1){
fprintf(stderr," ERROR wrong rort parameter \n");
return (-1); /* wrong mode */
}
if(iscale != 0 && iscale !=1 && iscale !=2 && iscale!=3 ){
fprintf(stderr," ERROR wrong iscale parameter \n");
return (-1); /* wrong mode */
}
if (!getparfloat("fangle",&fangle)) fangle = 0.0;
if (!getparfloat("langle",&langle)) langle = 45.0;
if (!getparfloat("dangle",&dangle)) dangle = 1.0;
if (!getpardouble("azimuth",&azimuth)) azimuth = 0.;
if (!getpardouble("vp1",&vp1)) vp1 = 2.0;
if (!getpardouble("vp2",&vp2)) vp2 = 2.0;
if (!getpardouble("vs1",&vs1)) vs1 = 1.0;
if (!getpardouble("vs2",&vs2)) vs2 = 1.0;
if (!getpardouble("rho1",&rho1)) rho1 = 2.7;
if (!getpardouble("rho2",&rho2)) rho2 = 2.7;
if (!getpardouble("eps1",&eps1)) eps1 = 0.;
if (!getpardouble("eps2",&eps2)) eps2 = 0.;
if (!getpardouble("delta1",&delta1)) delta1 = 0.;
if (!getpardouble("delta2",&delta2)) delta2 = 0.;
if (!getpardouble("gamma1",&gamma1)) gamma1 = 0.;
if (!getpardouble("gamma2",&gamma2)) gamma2 = 0.;
if (getparstring("outparfile",&outparfile)) {
outparfp = efopen(outparfile,"w");
} else {
outparfp = efopen("outpar","w");
}
if (getparstring("coeffile",&coeffile)) {
coeffp = efopen(coeffile,"w");
} else {
coeffp = efopen("coeff.data","w");
}
/****** some debugging information ******************/
if(info){
ddprint(azimuth);
ddprint(vp1); ddprint(vs1); ddprint(rho1);
ddprint(eps1); ddprint(delta1); ddprint(gamma1);
ddprint(vp2); ddprint(vs2); ddprint(rho2);
ddprint(eps2); ddprint(delta2); ddprint(gamma2);
}
/* convert into rad */
azimuth=azimuth*PI /180.;
sazi=sin(azimuth);
cazi=cos(azimuth);
/****** convertion into cij's ************************/
if (!thom2stiffTI(vp1,vs1,eps1,delta1,gamma1,PI/2.,spar1,1) ){
fprintf(stderr," \n ERROR in thom2stiffTI (1) \n");
return (-1);
}
if (!thom2stiffTI(vp2,vs2,eps2,delta2,gamma2,PI/2.,spar2,1) ){
fprintf(stderr,"\n ERROR in thom2stiffTI (2) \n");
return (-1);
}
/***** more debugging output ************************/
if(info){
diprint(modei);
diprint(modet);
diprint(rort);
ddprint(spar1->a1111);
ddprint(spar1->a3333);
ddprint(spar1->a1133);
ddprint(spar1->a1313);
ddprint(spar1->a2323);
ddprint(spar1->a1212);
ddprint(spar2->a1111);
ddprint(spar2->a3333);
ddprint(spar2->a1133);
ddprint(spar2->a1313);
ddprint(spar2->a2323);
ddprint(spar2->a1212);
}
/******** find generated wave type-index ************/
/* reflect_P (0) reflect_S (1) transm_P (2) transm_S (3) */
if(modet == 0 && rort==1)
index = 0;
else if(modet == 1 && rort==1)
index = 1;
else if(modet == 2 && rort==1)
index = 2;
else if(modet == 0 && rort==0)
index = 3;
else if(modet == 1 && rort==0)
index = 4;
else if(modet == 2 && rort==0)
index = 5;
else {
fprintf(stderr,"\n ERROR wrong (index) \n ");
return (-1);
}
/***************** LOOP OVER ANGLES ************************/
for(angle=fangle,iangle=0;angle<=langle;angle+=dangle){
if(info) ddprint(angle);
sangle=(double) angle*PI/180;
cangle=cos(sangle);
sangle=sin(sangle);
/* get horizontal slowness */
if(p_hor3DTIH(spar1,modei,sangle,cangle,sazi,cazi,&p)!=1){
fprintf(stderr,"\n ERROR in p_hor3DTIH \n ");
return (-1);
}
/* compute reflection/transmission coefficient */
if(graebner3D(spar1,spar2,rho1,rho2,modei,modet,rort,
sazi,cazi,p,coeff,a,ipvt,z,rcond)!=1){
fprintf(stderr,"\n ERROR in p_hor3DTIH \n ");
return (-1);
}
++iangle;
if(iscale==0)
anglef=(float) angle;
else if(iscale==1)
anglef=(float) angle*PI/180.;
else if(iscale==2)
anglef=(float) p;
else if(iscale==3)
anglef=(float) sangle*sangle;
dummy= (float)coeff[index];
/* Binary output for x_t */
if(ibin==1){
fwrite(&anglef,sizeof(float),1,coeffp);
fwrite(&dummy,sizeof(float),1,coeffp);
/* ASCII output */
} else if(ibin==0){
fprintf(coeffp,"%f %f\n",anglef,dummy);
}
}
/********* No of output pairs for plotting ********/
if(ibin) fprintf(outparfp,"%i\n",iangle);
return 1;
}
int
main(int argc, char **argv)
{
int i2, n1, n2, npad1, npad2;
int npow1, npow2, nstage1, nstage2, nfilter, nsize, nmax;
float **f, **g;
waveFilter *filter;
float ave, step;
int *qx;
memBUFF *ibuff, *obuff;
initargs(argc, argv);
requestdoc(1);
/* get the parameters */
fread(&nsize, sizeof(int), 1, stdin);
fread(&n1, sizeof(int), 1, stdin);
fread(&n2, sizeof(int), 1, stdin);
fread(&nfilter, sizeof(int), 1, stdin);
fread(&nstage1, sizeof(int), 1, stdin);
fread(&nstage2, sizeof(int), 1, stdin);
fread(&ave, sizeof(float), 1, stdin);
fread(&step, sizeof(float), 1, stdin);
/* regular sizes */
if(n1==1)
{
npow1 = 0;
npad1 = 1;
}
else
{
npow1 = 0; while(((n1-1)>>npow1)!=0) npow1 ++;
npad1 = 1<<npow1;
}
if(n2==1)
{
npow2 = 0;
npad2 = 1;
}
else
{
npow2 = 0; while(((n2-1)>>npow2)!=0) npow2 ++;
npad2 = 1<<npow2;
}
/* allocate spaces */
f = alloc2float(npad1,npad2);
g = alloc2float(npad1,npad2);
qx = alloc1int(npad1*npad2);
/* allocate the buffers */
nmax = 2*npad1*npad2;
ibuff = buffAlloc1(nsize);
obuff = buffAlloc1(nmax);
/* filter to use */
filter = waveGetfilter(nfilter);
/* read data */
fread(ibuff->code, sizeof(char), nsize, stdin);
/* Huffman decoding */
buffRewind(ibuff);
if(huffDecompress(ibuff, obuff) == MEM_EOB)
err("Inconsistent data \n");
/* run-length decoding */
buffRealloc1(obuff, obuff->pos);
buffRealloc1(ibuff, nmax);
buffRewind(obuff);
buffRewind(ibuff);
codeDesilence(obuff, ibuff);
/* prefix decoding */
buffRealloc1(ibuff, ibuff->pos);
buffRewind(ibuff);
if(pDecode(ibuff, qx, npad1*npad2) == MEM_EOB)
err("Inconsistent data \n");
/* dequantization */
uniDequant(g[0], npad1*npad2, ave, step, qx);
/* peform the transform */
waveTrans_2(f, g, filter, npow1, npow2,
nstage1, nstage2, 1);
/* reconstruction */
for(i2=0; i2<n2; i2++)
fwrite(f[i2], sizeof(float), n1, stdout);
return EXIT_SUCCESS;
}
int main(int argc, char **argv)
{
int i,ix,it; /* loop counters */
int wtype; /* =1 psv. =2 sh wavefields */
int wfield; /* =1 displcement =2 velocity =3 acceleration */
int stype; /* source type */
int int_type; /* =1 for trapezoidal rule. =2 for Filon */
int flt; /* =1 apply earth flattening correction */
int rand; /* =1 for random velocity layers */
int qopt; /* some flag ???? */
int vsp; /* =1 for vsp, =0 otherwise */
int win; /* =1 if frequency windowing required */
int verbose; /* flag to output processing information */
int nt; /* samples per trace in output traces */
int ntc; /* samples per trace in computed traces */
int nx; /* number of output traces */
int np; /* number of ray parameters */
int nlint=0; /* number of times layer interp is required */
int lsource; /* layer on top of which the source is located*/
int nw; /* number of frequencies */
int nor; /* number of receivers */
int nlayers; /* number of reflecting layers */
int layern;
int nrand_layers; /* maximum number of random layers permitted */
int nf; /* number of frequencies in output traces */
int *filters_phase=NULL; /* =0 for zero phase, =1 for minimum phase fil*/
int nfilters; /* number of required filters */
int wavelet_type; /* =1 spike =2 ricker1 =3 ricker2 =4 akb */
float dt; /* time sampling interval */
float tsec; /* trace length in seconds */
float fpeak; /* peak frequency for output wavelet */
float fref; /* first frequency */
float p2w; /* maximum ray parameter value */
float bp; /* smallest ray parameter (s/km) */
float bx; /* beginning of range in Kms. */
float fx; /* final range in Kms. */
float dx; /* range increment in Kms. */
float pw1,pw2,pw3,pw4; /* window ray parameters (to apply taper) */
float h1; /* horizontal linear part of the source */
float h2; /* vertical linear part of the source */
float m0; /* seismic moment */
float m1,m2,m3; /* components of the moment tensor */
float delta; /* dip */
float lambda; /* rake */
float phis; /* azimuth of the fault plane */
float phi; /* azimuth of the receiver location */
float sdcl,sdct; /* standar deviation for p and s-wave vels */
float z0=0.0; /* reference depth */
float zlayer; /* thickness of random layers */
int layer; /* layer over on top of which to compute rand*/
float tlag; /* time lag in output traces */
float red_vel; /* erducing velocity */
float w1=0.0; /* low end frequency cutoff for taper */
float w2=0.0; /* high end frequency cutoff for taper */
float wrefp; /* reference frequency for p-wave velocities */
float wrefs; /* reference frequency for s-wave velocities */
float epsp; /* .... for p-wave velocities */
float epss; /* .... for p-wave velocities */
float sigp; /* .... for p-wave velocities */
float sigs; /* .... for s-wave velocities */
float fs; /* sampling parameter, usually 0.07<fs<0.12 */
float decay; /* decay factor to avoid wraparound */
int *lobs; /* layers on top of which lay the receivers */
int *nintlayers=NULL; /* array of number of layers to interpolate */
int *filters_type; /* array of 1 lo cut, 2 hi cut, 3 notch */
float *dbpo=NULL; /* array of filter slopes in db/octave */
float *f1=NULL; /* array of lo frequencies for filters */
float *f2=NULL; /* array of high frequencies for filters */
float *cl; /* array of compressional wave velocities */
float *ql; /* array of compressional Q values */
float *ct; /* array of shear wave velocities */
float *qt; /* array of shear Q values */
float *rho; /* array of densities */
float *t; /* array of absolute layer thickness */
int *intlayers=NULL; /* array of layers to interpolate */
float *intlayth=NULL; /* array of thicknesses over which to interp */
float **wavefield1; /* array for pressure wavefield component */
float **wavefield2=NULL;/* array for radial wavefield component */
float **wavefield3=NULL;/* array for vertical wavefield component */
char *lobsfile=""; /* input file receiver layers */
char *clfile=""; /* input file of p-wave velocities */
char *qlfile=""; /* input file of compressional Q-values */
char *ctfile=""; /* input file of s-wave velocities */
char *qtfile=""; /* input file of shear Q-values */
char *rhofile=""; /* input file of density values */
char *tfile=""; /* input file of absolute layer thicknesses */
char *intlayfile=""; /* input file of layers to interpolate */
char *nintlayfile=""; /* input file of number of layers to interp */
char *intlaythfile=""; /*input file of layer thickness where to inter*/
char *filtypefile=""; /* input file of filter types to apply */
char *fphfile=""; /* input file of filters phases */
char *dbpofile=""; /* input file of filter slopes in db/octave */
char *f1file=""; /* input file of lo-end frequency */
char *f2file=""; /* input file of hi-end frequency */
char *wfp=""; /* output file of pressure */
char *wfr=""; /* output file of radial wavefield */
char *wfz=""; /* output file of vertical wavefield */
char *wft=""; /* output file of tangential wavefield */
char *outf=""; /* output file for processing information */
FILE *wfp_file; /* file pointer to output pressure */
FILE *wfr_file; /* file pointer to output radial wavefield */
FILE *wfz_file; /* file pointer to output vertical wavefield */
FILE *wft_file; /* file pointer to output tangential wavefield*/
FILE *outfp=NULL; /* file pointer to processing information */
FILE *infp; /* file pointer to input information */
/* hook up getpar to handle the parameters */
initargs(argc,argv);
requestdoc(0); /* no input data */
/* get required parameter, seismic moment */
if (!getparfloat("m0",&m0))
err("error: the seismic moment, m0, is a required parameter\n");
/*********************************************************************/
/* get general flags and set their defaults */
if (!getparint("rand",&rand)) rand = 0;
if (!getparint("qopt",&qopt)) qopt = 0;
if (!getparint("stype",&stype)) stype = 1;
if (!getparint("wtype",&wtype)) wtype = 1;
if (!getparint("wfield",&wfield)) wfield = 1;
if (!getparint("int_type",&int_type)) int_type= 1;
if (!getparint("flt",&flt)) flt = 0;
if (!getparint("vsp",&vsp)) vsp = 0;
if (!getparint("win",&win)) win = 0;
if (!getparint("wavelet_type",&wavelet_type)) wavelet_type = 1;
if (!getparint("verbose",&verbose)) verbose = 0;
/* get model parameters and set their defaults */
if (!getparint("lsource",&lsource)) lsource = 0;
if (!getparfloat("fs",&fs)) fs = 0.07;
if (!getparfloat("decay",&decay)) decay = 50.0;
if (!getparfloat("tsec",&tsec)) tsec = 2.048;
/* get response parameters and set their defaults */
if (!getparfloat("fref",&fref)) fref = 1.0;
if (!getparint("nw",&nw)) nw = 100;
if (!getparint("nor",&nor)) nor = 100;
if (!getparint("np",&np)) np = 1300;
if (!getparfloat("p2w",&p2w)) p2w = 5.0;
if (!getparfloat("bx",&bx)) bx = 0.005;
if (!getparfloat("bp",&bp)) bp = 0.0;
if (!getparfloat("fx",&fx)) fx = 0.1;
if (!getparfloat("dx",&dx)) dx = 0.001;
if (!getparfloat("pw1",&pw1)) pw1 = 0.0;
if (!getparfloat("pw2",&pw2)) pw2 = 0.1;
if (!getparfloat("pw3",&pw3)) pw3 = 6.7;
if (!getparfloat("pw4",&pw4)) pw4 = 7.0;
if (!getparfloat("h1",&h1)) h1 = 1.0;
if (!getparfloat("h2",&h2)) h2 = 0.0;
/* get output parameters and set their defaults */
if (!getparint("nx",&nx)) nx = 100;
if (!getparfloat("dt",&dt)) dt = 0.004;
if (!getparint("nt",&nt)) nt = tsec/dt;
if (!getparint("nf",&nf)) nf = 50;
if (!getparfloat("red_vel",&red_vel)) red_vel = 5;
if (!getparfloat("fpeak",&fpeak)) fpeak = 25.;
if (!getparfloat("tlag",&tlag)) tlag = 0.;
/* get names of output files */
if (wtype==1) {
getparstring("wfp",&wfp);
getparstring("wfr",&wfr);
getparstring("wfz",&wfz);
} else if (wtype==2) {
getparstring("wft",&wft);
} else err ("wtype has to be zero or one");
/*********************************************************************/
/* get or compute moment tensor components */
if (stype==1) {
/* get source parameters */
if (!getparfloat("delta",&delta))
err("if stype==1, delta is a required parameter\n");
if (!getparfloat("lambda",&lambda))
err("if stype==1, lambda is a required parameter\n");
if (!getparfloat("phis",&phis))
err("if stype==1, phis is a required parameter\n");
if (!getparfloat("phi",&phi))
err("if stype==1, phi is a required parameter\n");
/* compute moment tensor components */
compute_moment_tensor (wtype, phi, lambda, delta, phis, m0,
&m1, &m2, &m3);
} else if (stype==2) {
/* get moment tensor components from input */
if (!getparfloat("m1",&m1))
err("if stype==2, m1 is a required parameter\n");
if (!getparfloat("m2",&m2))
err("if stype==2, m2 is a required parameter\n");
if (!getparfloat("m3",&m3))
err("if stype==2, m3 is a required parameter\n");
} else err("error, stype flag has to be one or two\n");
/*********************************************************************/
/* if q-option is not requesed, set corresponding parameters to zero */
if (!getparint("layern",&layern)) layern =0;
if (!getparfloat("wrefp",&wrefp)) wrefp =0.0;
if (!getparfloat("wrefs",&wrefs)) wrefs =0.0;
if (!getparfloat("epsp",&epsp)) epsp =0.0;
if (!getparfloat("epss",&epss)) epss =0.0;
if (!getparfloat("sigp",&sigp)) sigp =0.0;
if (!getparfloat("sigs",&sigs)) sigs =0.0;
/*********************************************************************/
/* get number of layers and check input parameters */
if (*clfile=='\0') { /* p-wave vels input from the comand line */
nlayers=countparval("cl");
} else { /* p-wave vels input from a file */
getparint("nlayers",&nlayers);
}
if (*ctfile=='\0') { /* s-wave vels input from the comand line */
if (nlayers !=countparval("cl"))
err("number of p-wave and s-wave velocities"
"has to be the same");
}
if (*qlfile=='\0') { /* compressional q-values from comand line */
if (nlayers !=countparval("ql"))
err("number of p-wave velocities and q-values"
"has to be the same");
}
if (*qtfile=='\0') { /* shear q-values input from comand line */
if (nlayers !=countparval("qt"))
err("number of p-wave velocities and shear q-values"
"has to be the same");
}
if (*rhofile=='\0') { /* densities input from comand line */
if (nlayers !=countparval("rho"))
err("number of p-wave velocities and densities"
"has to be the same");
}
if (*tfile=='\0') { /* layer thicknesses input from comand line */
if (nlayers !=countparval("t"))
err("number of p-wave velocities and thicknesses"
"has to be the same");
}
if (int_type!=1 && int_type!=2) err("int_type flag has to be one or two");
/*********************************************************************/
/* if layer interpolation is requested, get parameters */
if (*intlayfile !='\0') {
getparint("nlint",&nlint);
if ((infp=efopen(intlayfile,"r"))==NULL)
err("cannot open file of layer interp=%s\n",intlayfile);
intlayers=alloc1int(nlint);
fread (intlayers,sizeof(int),nlint,infp);
efclose(infp);
} else if (countparval("intlayers") !=0) {
nlint=countparval("intlayers");
intlayers=alloc1int(nlint);
getparint("intlayers",intlayers);
}
if (*nintlayfile !='\0') {
if ((infp=efopen(nintlayfile,"r"))==NULL)
err("cannot open file of layer inter=%s\n",nintlayfile);
nintlayers=alloc1int(nlint);
fread (nintlayers,sizeof(int),nlint,infp);
efclose(infp);
} else if (countparval("nintlayers") !=0) {
if (nlint !=countparval("nintlayers"))
err("number of values in intlay and nintlay not equal");
nintlayers=alloc1int(nlint);
getparint("nintlayers",nintlayers);
}
if (*intlaythfile !='\0') {
if ((infp=efopen(intlaythfile,"r"))==NULL)
err("cannot open file=%s\n",intlaythfile);
intlayth=alloc1float(nlint);
fread (intlayth,sizeof(int),nlint,infp);
efclose(infp);
} else if (countparval("intlayth") !=0) {
if (nlint !=countparval("intlayth"))
err("# of values in intlay and intlayth not equal");
intlayth=alloc1float(nlint);
getparfloat("intlayth",intlayth);
}
/* update total number of layers */
if (nlint!=0) {
for (i=0; i<nlint; i++) nlayers +=intlayers[i]-1;
}
/*********************************************************************/
/* if random velocity layers requested, get parameters */
if (rand==1) {
getparint("layer",&layer);
getparint("nrand_layers",&nrand_layers);
getparfloat("zlayer",&zlayer);
getparfloat("sdcl",&sdcl);
getparfloat("sdct",&sdct);
} else nrand_layers=0;
/*********************************************************************/
/* allocate space */
cl = alloc1float(nlayers+nrand_layers);
ct = alloc1float(nlayers+nrand_layers);
ql = alloc1float(nlayers+nrand_layers);
qt = alloc1float(nlayers+nrand_layers);
rho = alloc1float(nlayers+nrand_layers);
t = alloc1float(nlayers+nrand_layers);
lobs = alloc1int(nor+1);
lobs[nor]=0;
/*********************************************************************/
/* read input parameters from files or command line */
if (*clfile !='\0') { /* read from a file */
if ((infp=efopen(clfile,"r"))==NULL)
err("cannot open file of pwave velocities=%s\n",clfile);
fread(cl,sizeof(float),nlayers,infp);
efclose(infp);
} else getparfloat("cl",cl); /* get from command line */
if (*qlfile !='\0') {
if ((infp=efopen(qlfile,"r"))==NULL)
err("cannot open file of compressional Q=%s\n",qlfile);
fread(ql,sizeof(float),nlayers,infp);
efclose(infp);
} else getparfloat("ql",ql);
if (*ctfile !='\0') {
if ((infp=efopen(ctfile,"r"))==NULL)
err("cannot open file of swave velocities=%s\n",ctfile);
fread(ct,sizeof(float),nlayers,infp);
efclose(infp);
} else getparfloat("ct",ct);
if (*qtfile !='\0') {
if ((infp=efopen(qtfile,"r"))==NULL)
err("cannot open file of shear Q=%s\n",qtfile);
fread(qt,sizeof(float),nlayers,infp);
efclose(infp);
} else getparfloat("qt",qt);
if (*rhofile !='\0') {
if ((infp=efopen(rhofile,"r"))==NULL)
err("cannot open file of densities=%s\n",rhofile);
fread(rho,sizeof(float),nlayers,infp);
efclose(infp);
} else getparfloat("rho",rho);
if (*tfile !='\0') {
if ((infp=efopen(tfile,"r"))==NULL)
err("cannot open file of thicknesses=%s\n",tfile);
fread(t,sizeof(float),nlayers,infp);
efclose(infp);
} else getparfloat("t",t);
if (*lobsfile !='\0') {
if ((infp=efopen(lobsfile,"r"))==NULL)
err("can't open file of receiver layers=%s\n",lobsfile);
fread(lobs,sizeof(int),nor,infp);
efclose(infp);
} else getparint("lobs",lobs);
/*********************************************************************/
/* if requested, do interpolation and/or parameter adjustment */
if (nlint!=0)
parameter_interpolation (nlayers, intlayers, nintlayers,
intlayth, cl, ql, ct, qt, rho, t);
/* if requested, compute random velocity layers */
if (rand==1) {
random_velocity_layers (&nlayers, &lsource, nrand_layers, sdcl,
sdct, layer, zlayer, cl, ql, ct, qt, rho, t);
}
/* if requested, apply earth flattening approximation */
if (flt==1) {
apply_earth_flattening (nlayers, z0, cl, ct, rho, t);
}
/*********************************************************************/
/* get filter parameters */
if (*filtypefile !='\0') {
if ((infp=efopen(filtypefile,"r"))==NULL)
err("cannot open file=%s\n",filtypefile);
getparint("nfilters",&nfilters);
filters_type=alloc1int(nfilters);
fread (filters_type,sizeof(int),nfilters,infp);
efclose(infp);
} else {
nfilters=countparval("filters_type");
filters_type=alloc1int(nfilters);
getparint("filters_type",filters_type);
}
if (*fphfile !='\0') {
if ((infp=efopen(fphfile,"r"))==NULL)
err("cannot open file=%s\n",fphfile);
filters_phase=alloc1int(nfilters);
fread (filters_phase,sizeof(float),nfilters,infp);
efclose(infp);
} else if (nfilters == countparval("filters_phase")) {
filters_phase=alloc1int(nfilters);
getparint("filters_phase",filters_phase);
} else err("number of elements infilterstype and phase must be equal");
if (*dbpofile !='\0') {
if ((infp=efopen(dbpofile,"r"))==NULL)
err("cannot open file=%s\n",dbpofile);
dbpo=alloc1float(nfilters);
fread (dbpo,sizeof(float),nfilters,infp);
efclose(infp);
} else if (nfilters == countparval("dbpo")) {
dbpo=alloc1float(nfilters);
getparfloat("dbpo",dbpo);
} else err("number of elements in filters_type and dbpo must be equal");
if (*f1file !='\0') {
if ((infp=efopen(f1file,"r"))==NULL)
err("cannot open file=%s\n",f1file);
f1=alloc1float(nfilters);
fread (f1,sizeof(float),nfilters,infp);
efclose(infp);
} else if (nfilters == countparval("f1")) {
f1=alloc1float(nfilters);
getparfloat("f1",f1);
} else err("number of elements in filters_type and f1 must be equal");
if (*f2file !='\0') {
if ((infp=efopen(f2file,"r"))==NULL)
err("cannot open file=%s\n",f2file);
f2=alloc1float(nfilters);
fread (f2,sizeof(float),nfilters,infp);
efclose(infp);
} else if (nfilters == countparval("f2")) {
f2=alloc1float(nfilters);
getparfloat("f2",f2);
} else err("number of elements in filters_type and f2 must be equal");
/*********************************************************************/
/* allocate space for wavefield computations */
wavefield1=alloc2float(nt,nx);
if (wtype==1) {
wavefield2=alloc2float(nt,nx);
wavefield3=alloc2float(nt,nx);
}
/* get name of output file for processing information */
if (verbose==2||verbose==3) {
if (!getparstring("outf",&outf)) outf="info";
if ((outfp=efopen(outf,"w"))==NULL) {
warn("cannot open processing file =%s, no processing\n"
"information file will be generated\n",outf);
verbose=1;
}
}
/* initialize wavefields */
if (wtype==1) {
for (ix=0;ix<nx;ix++) {
for (it=0;it<nt;it++) {
wavefield1[ix][it]=0.0;
wavefield2[ix][it]=0.0;
wavefield3[ix][it]=0.0;
}
}
} else if (wtype==2) {
for (ix=0;ix<nx;ix++) {
for (it=0;it<nt;it++) {
wavefield1[ix][it]=0.0;
}
}
}
/* number of time samples in computed traces */
ntc=tsec/dt;
if (int_type==2) bp=0.0;
/*********************************************************************/
/* Now, compute the actual reflectivities */
compute_reflectivities (int_type, verbose, wtype, wfield, vsp, flt,
win, nx, nt, ntc, nor, nf, nlayers, lsource, layern, nfilters,
filters_phase, nw, np, bp, tlag, red_vel, w1, w2, fx, dx, bx,
fs, decay, p2w, tsec, fref, wrefp, wrefs, epsp, epss, sigp,
sigs, pw1, pw2, pw3, pw4, h1, h2, m1, m2, m3, fref, lobs,
filters_type, dbpo, f1, f2, cl, ct, ql, qt, rho, t, wavefield1,
wavefield2, wavefield3, outfp);
/*********************************************************************/
/* if open, close processing information file */
if (verbose==2||verbose==3) efclose(outfp);
/* convolve with a wavelet and write the results out */
if (wtype==1) { /* PSV */
/* convolve with a wavelet to produce the seismograms */
convolve_wavelet (wavelet_type, nx, nt, dt, fpeak, wavefield1);
convolve_wavelet (wavelet_type, nx, nt, dt, fpeak, wavefield2);
convolve_wavelet (wavelet_type, nx, nt, dt, fpeak, wavefield3);
/* output results in SU format */
if(*wfp!='\0'){
if ((wfp_file=efopen(wfp,"w"))==NULL)
err("cannot open pressure file=%s\n",wfp);
{ register int ix;
for (ix=0; ix<nx; ix++) {
for (it=0; it<nt; it++)
tr1.data[it]=wavefield1[ix][it];
/* headers*/
tr1.ns=nt;
tr1.dt=1000*(int)(1000*dt);
tr1.offset=(bx+ix*dx)*1000;
/* output trace */
fputtr(wfp_file, &tr1);
}
efclose (wfp_file);
}
}
if (*wfr !='\0') {
if ((wfr_file=efopen(wfr,"w"))==NULL)
err("cannot open radial wfield file=%s\n",wfr);
{ register int ix;
for (ix=0; ix<nx; ix++) {
for (it=0; it<nt; it++)
tr2.data[it]=wavefield2[ix][it];
tr2.ns=nt;
tr2.dt=1000*(int)(1000*dt);
tr2.offset=(bx+ix*dx)*1000;
fputtr(wfr_file, &tr2);
}
efclose (wfr_file);
}
}
if (*wfz !='\0') {
if ((wfz_file=efopen(wfz,"w"))==NULL)
err("canno open vertical field file=%s\n",wfz);
{ register int ix;
for (ix=0; ix<nx; ix++) {
for (it=0; it<nt; it++)
tr3.data[it]=wavefield3[ix][it];
tr3.ns=nt;
tr3.dt=1000*(int)(1000*dt);
tr3.offset=(bx+ix*dx)*1000;
fputtr(wfz_file, &tr3);
}
efclose (wfz_file);
}
}
/* free allocated space */
free2float(wavefield1);
free2float(wavefield2);
free2float(wavefield3);
} else if (wtype==2) { /* SH */
/* convolve with a wavelet to produce the seismogram */
convolve_wavelet (wavelet_type, nx, nt, dt, fpeak, wavefield1);
/* output the result in SU format */
if (*wft !='\0') {
if ((wft_file=efopen(wft,"w"))==NULL)
err("cannot open tangential file=%s\n",wft);
{ register int ix;
for (ix=0; ix<nx; ix++) {
for (it=0; it<nt; it++)
tr1.data[it]=wavefield1[ix][it];
tr1.ns=nt;
tr1.dt=1000*(int)(1000*dt);
tr1.offset=(bx+ix*dx)*1000;
fputtr(wft_file, &tr1);
}
efclose (wft_file);
}
}
/* free allocated space */
free2float(wavefield1);
}
/* free workspace */
free1float(cl);
free1float(ct);
free1float(ql);
free1float(qt);
free1float(rho);
free1float(t);
free1int(lobs);
free1int(filters_type);
free1int(filters_phase);
free1float(dbpo);
free1float(f1);
free1float(f2);
return EXIT_SUCCESS;
}
main (int argc, char **argv)
{
int n1,n2,n3,
n1s,n2s,n3s,
id1s,id2s,id3s,
if1s,if2s,if3s,
*ix1s,*ix2s,*ix3s,
i1s,i2s,i3s,
i1,i2,i3,
offset;
float *p,*ps;
FILE *infp=stdin,*outfp=stdout;
/* hook up getpar to handle the parameters */
initargs(argc,argv);
askdoc(0);
/* get optional parameters */
if (!getparint("n1",&n1)) {
if (fseek(infp,0L,2)==-1)
err("input file size unknown; specify n1\n");
n1 = eftell(infp)/sizeof(float);
}
if (!getparint("n2",&n2)) {
if (fseek(infp,0L,2)==-1)
err("input file size unknown; specify n2\n");
n2 = eftell(infp)/(n1*sizeof(float));
}
if (!getparint("n3",&n3)) {
if (fseek(infp,0L,2)==-1)
err("input file size unknown; specify n3\n");
n3 = eftell(infp)/(n2*n1*sizeof(float));
}
ix1s = alloc1int(countparval("ix1s"));
if ((n1s=getparint("ix1s",ix1s))==0) {
free1int(ix1s);
if (!getparint("id1s",&id1s)) id1s = 1;
if (!getparint("if1s",&if1s)) if1s = 0;
if (!getparint("n1s",&n1s)) n1s = 1+(n1-if1s-1)/id1s;
ix1s = alloc1int(n1s);
for (i1s=0,i1=if1s; i1s<n1s; i1s++,i1+=id1s)
ix1s[i1s] = i1;
}
ix2s = alloc1int(countparval("ix2s"));
if ((n2s=getparint("ix2s",ix2s))==0) {
free1int(ix2s);
if (!getparint("id2s",&id2s)) id2s = 1;
if (!getparint("if2s",&if2s)) if2s = 0;
if (!getparint("n2s",&n2s)) n2s = 1+(n2-if2s-1)/id2s;
ix2s = alloc1int(n2s);
for (i2s=0,i2=if2s; i2s<n2s; i2s++,i2+=id2s)
ix2s[i2s] = i2;
}
ix3s = alloc1int(countparval("ix3s"));
if ((n3s=getparint("ix3s",ix3s))==0) {
free1int(ix3s);
if (!getparint("id3s",&id3s)) id3s = 1;
if (!getparint("if3s",&if3s)) if3s = 0;
if (!getparint("n3s",&n3s)) n3s = 1+(n3-if3s-1)/id3s;
ix3s = alloc1int(n3s);
for (i3s=0,i3=if3s; i3s<n3s; i3s++,i3+=id3s)
ix3s[i3s] = i3;
}
/* check parameters */
for (i1s=0; i1s<n1s; i1s++)
if (ix1s[i1s]<0 || ix1s[i1s]>n1-1)
err("ix1s[%d]=%d is out of bounds!\n",i1s,ix1s[i1s]);
for (i2s=0; i2s<n2s; i2s++)
if (ix2s[i2s]<0 || ix2s[i2s]>n2-1)
err("ix2s[%d]=%d is out of bounds!\n",i2s,ix2s[i2s]);
for (i3s=0; i3s<n3s; i3s++)
if (ix3s[i3s]<0 || ix3s[i3s]>n3-1)
err("ix3s[%d]=%d is out of bounds!\n",i3s,ix3s[i3s]);
/* allocate space for input and output arrays */
p = ealloc1float(n1);
ps = ealloc1float(n1s);
/* loop over 3rd dimension */
for (i3s=0; i3s<n3s; i3s++) {
/* loop over 2nd dimension */
for (i2s=0; i2s<n2s; i2s++) {
/* find beginning of input array */
offset = (ix2s[i2s]+ix3s[i3s]*n2)*n1*sizeof(float);
efseek(infp,offset,0);
/* read input array, if it exists */
if (fread(p,sizeof(float),n1,infp)==n1) {
/* loop over 1st dimension */
for (i1s=0; i1s<n1s; i1s++) {
ps[i1s] = p[ix1s[i1s]];
}
/* if input does not exist */
} else {
err("no input for ix2s[%d]=%d ix3s[%d]=%d!\n",
i2s,ix2s[i2s],
i3s,ix3s[i3s]);
}
/* write trace to output file */
efwrite(ps,sizeof(float),n1s,outfp);
}
}
}
void quantFixerror(float **x, float error, void *inconf, void *qstate)
/*******************************************************************************
quantization
********************************************************************************
x array[][] for the floats
error percent RMS error tolerable
inconf configuration info
qstate quantization status
********************************************************************************
Author: Tong Chen, 07/20/94
Modifier: Tong Chen, 07/28/94, for API, without iteration
*******************************************************************************/
{
wpcCONFIG *config = (wpcCONFIG *) inconf;
wpcQUANT *quant = (wpcQUANT *) qstate;
int nblock, lblock, tileszt, tileszx, nsz;
int i;
int iblock;
float *fmax, *dev;
int **qx, *blockind;
unsigned char *flowflag, *cblockind;
float atmp, average;
float clip, loading, bound, step_factor, rn, ratio;
/* obtain the configuration info */
nblock = config->nblock;
lblock = config->lblock;
tileszt = config->tileszt;
tileszx = config->tileszx;
/* quantization status */
qx = quant->qx;
flowflag = quant->flowflag;
cblockind = quant->blockind;
nsz = tileszt*tileszx;
/* spaces */
fmax = alloc1float(nblock);
dev = alloc1float(nblock);
blockind = alloc1int(nblock);
rn = 1./((float) lblock);
/* for each difference block */
clip = 0.;
for(iblock = 0; iblock < nblock-1; iblock ++){
/* compute the maximum amplitude and deviation */
fmax[iblock] = 0.;
dev[iblock] = 0.;
for(i=0; i<lblock; i++){
atmp = ABS(x[iblock][i]);
if(fmax[iblock] < atmp) fmax[iblock] = atmp;
dev[iblock] += atmp*atmp;
}
clip += dev[iblock];
dev[iblock] *= rn;
dev[iblock] = sqrt(dev[iblock]);
}
/* for the average block */
average = 0.;
for(i=0;i<lblock;i++){
average += x[nblock-1][i];
}
average *= rn;
/* save this average for reconstruction */
quant->ave = average;
fmax[nblock-1] = dev[nblock-1] = 0.;
for(i=0; i<lblock; i++){
x[nblock-1][i] = x[nblock-1][i] - average;
atmp = ABS(x[nblock-1][i]);
if(fmax[nblock-1] < atmp) fmax[nblock-1] = atmp;
dev[nblock-1] += atmp*atmp;
}
clip += dev[nblock-1];
dev[nblock-1] *= rn;
dev[nblock-1] = sqrt(dev[nblock-1]);
clip = clip/((float) nsz);
clip = sqrt(clip);
/* if all zero, no quantization needed */
if(clip <= FLT_MIN){
quant->zeroflag = QUANTZEROFLAGY;
return;
}
/* not all zero */
quant->zeroflag = QUANTZEROFLAGN;
error = 100.*error;
clip *= error;
/* for underflow */
if(clip < FLT_MIN) clip = FLT_MIN;
ratio = QUANTERRATIO;
bound = ratio*clip;
step_factor = QUANTBYTEMAXINT/bound;
/* for overflow */
if(step_factor > FLT_MAX) step_factor = FLT_MAX;
quant->step = step_factor;
/* quantization */
for(iblock = 0; iblock < nblock; iblock ++){
for(i=0; i<lblock; i++){
atmp = x[iblock][i]*step_factor;
qx[iblock][i] = NINT(atmp);
}
loading = fmax[iblock]*step_factor;
if(loading > QUANTBYTEMAXINT)
flowflag[iblock] = QUANTFLOWFLAGY;
else
flowflag[iblock] = QUANTFLOWFLAGN;
}
/* sort the blocks using deviation to reduce entropy */
for(iblock=0; iblock<nblock; iblock++)
blockind[iblock] = iblock;
qkisort(nblock, dev, blockind);
for(iblock=0; iblock<nblock; iblock++)
cblockind[iblock] = blockind[iblock];
/* free spaces */
free((void *) fmax);
free((void *) dev);
free((void *) blockind);
}
main (int argc, char **argv)
{
/* declaration of variables */
FILE *fp; /* file pointer */
char *auxChar; /* auxiliar character */
char *modelFile = " "; /* elastic model file */
/* THICK - RHO - VP - QP - VS - QS */
int i, k, iProc, iR; /* counters */
int initF, lastF; /* initial and final frequencies */
int apl_pid; /* PVM process id control */
int nSamplesOrig; /* time series length */
int die; /* flag used to kill processes */
int pid; /* process id */
int nProc; /* number of processes */
int processControl; /* monitoring PVM start */
int *processes; /* array with process ids */
int FReceived; /* number of frequencies processed */
int nFreqProc; /* number of frequencies per process */
int nFreqPart; /* number of frequency partitions */
int **statusFreq; /* monitors processed frequencies */
int FInfo[2]; /* frequency delimiters */
int **procInfo; /* frequency limits for each processor */
float wallcpu; /* wall clock time */
float dt; /* time sampling interval */
float f; /* current frequency */
float fR; /* reference frequency */
float tMax; /* maximum recording time */
float *thick, *alpha, *beta,
*rho, *qP, *qS; /* elastic constants and thickness */
complex **freqPart; /* frequency arrays sent by the slaves */
complex **uRF, **uZF; /* final frequency components */
INFO info[1]; /* basic information for slaves */
/* Logging information */
/* CleanLog(); */
/* getting input */
initargs(argc, argv);
requestdoc(0);
if (!getparstring("model", &modelFile)) modelFile = "model";
if (!getparstring("recfile", &auxChar)) auxChar = " ";
sprintf(info->recFile, "%s", auxChar);
if (!getparint("directwave", &info->directWave)) info->directWave = 1;
if (!getparfloat("r1", &info->r1)) info->r1 = 0;
if (!getparint("nr", &info->nR)) info->nR = 148;
if (!getparfloat("dr", &info->dR)) info->dR = .025;
if (!getparfloat("zs", &info->zs)) info->zs = 0.001;
if (info->zs <= 0) info->zs = 0.001;
if (!getparfloat("u1", &info->u1)) info->u1 = 0.0002;
if (!getparfloat("u2", &info->u2)) info->u2 = 1.;
if (!getparint("nu", &info->nU)) info->nU = 1000;
if (!getparfloat("f1", &info->f1)) info->f1 = 2;
if (!getparfloat("f2", &info->f2)) info->f2 = 50;
if (!getparfloat("dt", &dt)) dt = 0.004;
if (!getparfloat("tmax", &tMax)) tMax = 8;
if (!getparfloat("F1", &info->F1)) info->F1 = 0;
if (!getparfloat("F2", &info->F2)) info->F2 = 0;
if (!getparfloat("F3", &info->F3)) info->F3 = 1;
if (!getparint("hanning", &info->hanningFlag)) info->hanningFlag = 0;
if (!getparfloat("wu", &info->percU)) info->percU = 5; info->percU /= 100;
if (!getparfloat("ww", &info->percW)) info->percW = 5; info->percW /= 100;
if (!getparfloat("fr", &fR)) fR = 1; info->wR = 2 * PI * fR;
if (!getparfloat("tau", &info->tau)) info->tau = 50;
if (!getparint("nproc", &nProc)) nProc = 1;
if (!getparint("nfreqproc", &nFreqProc) || nProc == 1) nFreqProc = 0;
if (!getparint("verbose", &info->verbose)) info->verbose = 0;
/* how many layers */
fp = fopen(modelFile,"r");
if (fp == NULL)
err("No model file!\n");
info->nL = 0;
while (fscanf(fp, "%f %f %f %f %f %f\n",
&f, &f, &f, &f, &f, &f) != EOF)
info->nL++;
info->nL--;
fclose(fp);
if (info->verbose)
fprintf(stderr,"Number of layers in model %s : %d\n",
modelFile, info->nL + 1);
/* if specific geometry, count number of receivers */
fp = fopen(info->recFile, "r");
if (fp != NULL)
{
info->nR = 0;
while (fscanf(fp, "%f\n", &f) != EOF)
info->nR++;
}
fclose(fp);
/* memory allocation */
alpha = alloc1float(info->nL + 1);
beta = alloc1float(info->nL + 1);
rho = alloc1float(info->nL + 1);
qP = alloc1float(info->nL + 1);
qS = alloc1float(info->nL + 1);
thick = alloc1float(info->nL + 1);
processes = alloc1int(nProc);
procInfo = alloc2int(2, nProc);
/* reading the file */
fp = fopen(modelFile,"r");
if (info->verbose)
fprintf(stderr,"Thickness rho vP qP vS qS\n");
for (i = 0; i < info->nL + 1; i++)
{
fscanf(fp, "%f %f %f %f %f %f\n", &thick[i], &rho[i], &alpha[i],
&qP[i], &beta[i], &qS[i]);
if (info->verbose)
fprintf(stderr," %7.4f %4.3f %3.2f %5.1f %3.2f %5.1f\n",
thick[i], rho[i], alpha[i], qP[i], beta[i], qS[i]);
}
fclose(fp);
/* computing frequency interval */
info->nSamples = NINT(tMax / dt) + 1;
nSamplesOrig = info->nSamples;
info->nSamples = npfar(info->nSamples);
/* slowness increment */
info->dU = (info->u2 - info->u1) / (float) info->nU;
/* computing more frequency related quatities */
tMax = dt * (info->nSamples - 1);
info->dF = 1. / (tMax);
f = info->dF;
while (f < info->f1) f += info->dF;
info->f1 = f;
while (f < info->f2) f += info->dF;
info->f2 = f;
initF = NINT(info->f1 / info->dF);
lastF = NINT(info->f2 / info->dF);
info->nF = lastF - initF + 1;
if (info->nF%2 == 0)
{
info->nF++;
lastF++;
}
/* attenuation of wrap-around */
info->tau = log(info->tau) / tMax;
if (info->tau > TAUMAX)
info->tau = TAUMAX;
if (info->verbose)
fprintf(stderr, "Discrete frequency range to model: [%d, %d]\n",
initF, lastF);
if (nFreqProc == 0)
nFreqProc = NINT((float) info->nF / (float) nProc + .5);
else
while (nFreqProc > info->nF) nFreqProc /= 2;
nFreqPart = NINT((float) info->nF / (float) nFreqProc + .5);
/* memory allocation for frequency arrays */
uRF = alloc2complex(info->nSamples / 2 + 1, info->nR);
uZF = alloc2complex(info->nSamples / 2 + 1, info->nR);
freqPart = alloc2complex(nFreqProc, info->nR);
statusFreq = alloc2int(3, nFreqPart);
/* defining frequency partitions */
for (k = initF, i = 0; i < nFreqPart; i++, k += nFreqProc)
{
statusFreq[i][0] = k;
statusFreq[i][1] = MIN(k + nFreqProc - 1, lastF);
statusFreq[i][2] = 0;
}
if (info->verbose)
fprintf(stderr, "Starting communication with PVM\n");
/* starting communication with PVM */
if ((apl_pid = pvm_mytid()) < 0)
{
err("Error enrolling master process");
/* exit(-1); */
}
fprintf(stderr, "Starting %d slaves ... ", nProc);
processControl = CreateSlaves(processes, PROCESS, nProc);
if (processControl != nProc)
{
err("Problem starting Slaves (%s)\n", PROCESS);
/* exit(-1); */
}
fprintf(stderr, " Ready \n");
info->nFreqProc = nFreqProc;
/* Broadcasting all processes common information */
BroadINFO(info, 1, processes, nProc, GENERAL_INFORMATION);
if (info->verbose) {
fprintf(stderr, "Broadcasting model information to all slaves\n");
fflush(stderr);
}
/* sending all profiles */
BroadFloat(thick, info->nL + 1, processes, nProc, THICKNESS);
BroadFloat(rho, info->nL + 1, processes, nProc, DENSITY);
BroadFloat(alpha, info->nL + 1, processes, nProc, ALPHA);
BroadFloat(qP, info->nL + 1, processes, nProc, QALPHA);
BroadFloat(beta, info->nL + 1, processes, nProc, BETA);
BroadFloat(qS, info->nL + 1, processes, nProc, QBETA);
/* freeing memory */
free1float(thick);
free1float(rho);
free1float(alpha);
free1float(qP);
free1float(beta);
free1float(qS);
/* sending frequency partitions for each process */
for (iProc = 0; iProc < nProc; iProc++)
{
FInfo[0] = statusFreq[iProc][0];
FInfo[1] = statusFreq[iProc][1];
if (info->verbose) {
fprintf(stderr,
"Master sending frequencies [%d, %d] out of %d to slave %d [id:%d]\n"
,FInfo[0], FInfo[1], info->nF, iProc, processes[iProc]);
fflush(stderr);
}
procInfo[iProc][0] = FInfo[0]; procInfo[iProc][1] = FInfo[1];
SendInt(FInfo, 2, processes[iProc], FREQUENCY_LIMITS);
statusFreq[iProc][2] = 1;
}
/* waiting modelled frequencies */
/* master process will send more frequencies if there's more work to do */
/* measuring elapsed time */
wallcpu = walltime();
/* reseting frequency counter */
FReceived = 0;
while (FOREVER)
{
pid = RecvCplx(freqPart[0], info->nR * nFreqProc, -1,
FREQUENCY_PARTITION_VERTICAL);
/* finding the frequency limits of this process */
iProc = 0;
while (pid != processes[iProc])
iProc++;
/* copying into proper place of the total frequency array */
for (iR = 0; iR < info->nR; iR++)
{
for (k = 0, i = procInfo[iProc][0]; i <= procInfo[iProc][1]; i++, k++)
{
uZF[iR][i] = freqPart[iR][k];
}
}
pid = RecvCplx(freqPart[0], info->nR * nFreqProc, -1,
FREQUENCY_PARTITION_RADIAL);
/* finding the frequency limits of this process */
iProc = 0;
while (pid != processes[iProc])
iProc++;
/* copying into proper place of the total frequency array */
for (iR = 0; iR < info->nR; iR++)
{
for (k = 0, i = procInfo[iProc][0]; i <= procInfo[iProc][1]; i++, k++)
{
uRF[iR][i] = freqPart[iR][k];
}
}
/* summing frequencies that are done */
FReceived += procInfo[iProc][1] - procInfo[iProc][0] + 1;
if (info->verbose)
fprintf(stderr, "Master received %d frequencies, remaining %d\n",
FReceived, info->nF - FReceived);
/* if (FReceived >= info->nF) break; */
/* defining new frequency limits */
i = 0;
while (i < nFreqPart && statusFreq[i][2])
i++;
if (i < nFreqPart)
{
/* there is still more work to be done */
/* tell this process to not die */
die = 0;
SendInt(&die, 1, processes[iProc], DIE);
FInfo[0] = statusFreq[i][0];
FInfo[1] = statusFreq[i][1];
if (info->verbose)
fprintf(stderr,
"Master sending frequencies [%d, %d] to slave %d\n",
FInfo[0], FInfo[1], processes[iProc]);
procInfo[iProc][0] = FInfo[0]; procInfo[iProc][1] = FInfo[1];
SendInt(FInfo, 2, processes[iProc], FREQUENCY_LIMITS);
statusFreq[i][2] = 1;
}
else
{
/* tell this process to die since there is no more work to do */
if (info->verbose)
fprintf(stderr, "Master ''killing'' slave %d\n", processes[iProc]);
die = 1;
SendInt(&die, 1, processes[iProc], DIE);
}
/* a check to get out the loop */
if (FReceived >= info->nF) break;
}
if (info->verbose)
fprintf(stderr, "Master ''killing'' remaining slaves\n");
/* getting elapsed time */
wallcpu = walltime() - wallcpu;
fprintf(stderr, "Wall clock time = %f seconds\n", wallcpu);
/* going to time domain */
memset( (void *) &trZ, (int) '\0', sizeof(trZ));
memset( (void *) &trR, (int) '\0', sizeof(trR));
trZ.dt = dt * 1000000;
trZ.ns = nSamplesOrig;
trR.dt = dt * 1000000;
trR.ns = nSamplesOrig;
/* z component */
for (iR = 0; iR < info->nR; iR++)
{
trZ.tracl = iR + 1;
/* inverse FFT */
pfacr(1, info->nSamples, uZF[iR], trZ.data);
for (i = 0; i < info->nSamples; i++)
{
/* compensating for the complex frequency */
trZ.data[i] *= exp(info->tau * i * dt);
}
puttr(&trZ);
}
/* r component */
for (iR = 0; iR < info->nR; iR++)
{
trR.tracl = info->nR + iR + 1;
/* inverse FFT */
pfacr(1, info->nSamples, uRF[iR], trR.data);
for (i = 0; i < info->nSamples; i++)
{
/* compensating for the complex frequency */
trR.data[i] *= exp(info->tau * i * dt);
}
puttr(&trR);
}
return(EXIT_SUCCESS);
}