void getBoundary(Atmosphere *atmos, Geometry *geometry)
{
int result, Nspect = Nlambda;
/* --- Read boundary conditions and irradiation. First VERTICAL
boundary conditions -- --------- */
switch (geometry->bvalue[TOP]) {
case IRRADIATED:
geometry->Itop = matrix_double(Nspect, geometry->Nx);
result = xdr_vector(&xdrs, (char *) geometry->Itop[0],
Nspect*geometry->Nx,
sizeof(double), (xdrproc_t) xdr_double);
break;
default:
geometry->Itop = NULL;
break;
}
switch (geometry->bvalue[BOTTOM]) {
case IRRADIATED:
geometry->Ibottom = matrix_double(Nspect, geometry->Nx);
result = xdr_vector(&xdrs, (char *) geometry->Ibottom[0],
Nspect*geometry->Nx,
sizeof(double), (xdrproc_t) xdr_double);
break;
default:
geometry->Ibottom = NULL;
break;
}
/* --- Get the HORIZONTAL boundary conditions -- ----------- */
switch (geometry->hboundary) {
case FIXED:
geometry->Ileft = matrix_double(Nspect, geometry->Nz);
result = xdr_vector(&xdrs, (char *) geometry->Ileft[0],
Nspect*geometry->Nz,
sizeof(double), (xdrproc_t) xdr_double);
geometry->Iright = matrix_double(Nspect, geometry->Nz);
result = xdr_vector(&xdrs, (char *) geometry->Iright[0],
Nspect*geometry->Nz,
sizeof(double), (xdrproc_t) xdr_double);
break;
case PERIODIC:
geometry->Ileft = NULL;
geometry->Iright = NULL;
break;
default:
break;
}
}
void LTEmolecule(Molecule *molecule)
{
/* --- Calculate partition functions for each molecular vibrational
state v of the molecule. LTE populations are then given by:
nv^*[k] = molecule->n * pfv[v][k] / pf[k].
Note: The actual LTE populations are calculated (in initSolution)
only after chemical equilibrium has been established.
-- -------------- */
register int k, v, J, kr;
char labelStr[MAX_LINE_SIZE];
double kT, gJ, **E;
MolecularLine *mrt;
if (!molecule->active) {
sprintf(messageStr, "Molecule must be active: %s\n", molecule->ID);
Error(ERROR_LEVEL_2, "LTEmolecule", messageStr);
}
/* --- Fill energy matrix -- -------------- */
E = matrix_double(molecule->Nv, molecule->NJ);
for (kr = 0; kr < molecule->Nrt; kr++) {
mrt = molecule->mrt + kr;
E[mrt->vi][(int) (mrt->gi - 1)/2] = mrt->Ei;
E[mrt->vj][(int) (mrt->gj - 1)/2] = mrt->Ej;
}
for (k = 0; k < atmos.Nspace; k++)
molecule->pf[k] = 0.0;
for (v = 0; v < molecule->Nv; v++) {
for (J = 0; J < molecule->NJ; J++) {
gJ = 2*J + 1;
for (k = 0; k < atmos.Nspace; k++)
molecule->pfv[v][k] +=
gJ * exp(-E[v][J] / (KBOLTZMANN * atmos.T[k]));
}
/* --- Also store the total partition function here -- --------- */
for (k = 0; k < atmos.Nspace; k++)
molecule->pf[k] += molecule->pfv[v][k];
}
freeMatrix((void **) E);
sprintf(labelStr, "LTEpops %3s", molecule->ID);
getCPU(4, TIME_POLL, labelStr);
}
/**
Returns the diagonal matrix of singular values.
@return S
*/
MatrixDouble svd_getS() {
int i, j;
if (S_matrix != NULL)
free_matrix_double(S_matrix, num_columns, num_columns);
S_matrix = matrix_double(num_columns, num_columns);
for (i = 0; i < num_columns; i++) {
for (j = 0; j < num_columns; j++) {
S_matrix[i][j] = 0.0;
}
S_matrix[i][i] = singular_values[i];
}
return (S_matrix);
}
void readAtmos_ncdf(int xi, int yi, Atmosphere *atmos, Geometry *geometry,
NCDF_Atmos_file *infile)
/* Reads the variables T, ne, vel, nh for a given (xi,yi) pair */
{
const char routineName[] = "readAtmos_ncdf";
size_t start[] = {0, 0, 0, 0}; /* starting values */
size_t count[] = {1, 1, 1, 1};
size_t start_nh[] = {0, 0, 0, 0, 0};
size_t count_nh[] = {1, 1, 1, 1, 1};
int ncid, ierror, i, j, z_varid;
bool_t old_moving;
double *Bx, *By, *Bz;
ncid = infile->ncid;
atmos->Nspace = geometry->Ndep = infile->nz;
/* read full T column, to see where to zcut */
start[0] = input.p15d_nt; count[0] = 1;
start[1] = (size_t) xi; count[1] = 1;
start[2] = (size_t) yi; count[2] = 1;
start[3] = 0; count[3] = infile->nz;
atmos->T = (double *) realloc(atmos->T, infile->nz * sizeof(double));
if ((ierror = nc_get_vara_double(ncid, infile->T_varid, start, count, atmos->T)))
ERR(ierror,routineName);
/* Finds z value for Tmax cut, redefines Nspace, reallocates arrays */
/* Tiago: not using this at the moment, only z cut in depth_refine */
if (input.p15d_zcut) {
setTcut(atmos, geometry, input.p15d_tmax);
} else {
mpi.zcut = 0;
}
/* Get z again */
start[0] = input.p15d_nt; count[0] = 1;
start[1] = mpi.zcut; count[1] = atmos->Nspace;
if ((ierror=nc_inq_varid(ncid, "z", &z_varid)))
ERR(ierror,routineName);
if ((ierror = nc_get_vara_double(ncid, z_varid, start, count, geometry->height)))
ERR(ierror,routineName);
start[0] = input.p15d_nt; count[0] = 1;
start[1] = (size_t) xi; count[1] = 1;
start[2] = (size_t) yi; count[2] = 1;
start[3] = mpi.zcut; count[3] = atmos->Nspace;
/* read variables */
if ((ierror = nc_get_vara_double(ncid, infile->T_varid, start, count, atmos->T)))
ERR(ierror,routineName);
if ((ierror = nc_get_vara_double(ncid, infile->ne_varid, start, count, atmos->ne)))
ERR(ierror,routineName);
if ((ierror = nc_get_vara_double(ncid, infile->vz_varid, start, count, geometry->vel)))
ERR(ierror,routineName);
/* vturb, if available */
if (infile->vturb_varid != -1) {
if ((ierror = nc_get_vara_double(ncid, infile->vturb_varid, &start[3], &count[3],
atmos->vturb))) ERR(ierror,routineName);
}
/* Read magnetic field */
if (atmos->Stokes) {
Bx = (double *) malloc(atmos->Nspace * sizeof(double));
By = (double *) malloc(atmos->Nspace * sizeof(double));
Bz = (double *) malloc(atmos->Nspace * sizeof(double));
/* Read in cartesian coordinates */
if ((ierror = nc_get_vara_double(ncid, infile->Bx_varid, start, count,
Bx))) ERR(ierror,routineName);
if ((ierror = nc_get_vara_double(ncid, infile->By_varid, start, count,
By))) ERR(ierror,routineName);
if ((ierror = nc_get_vara_double(ncid, infile->Bz_varid, start, count,
Bz))) ERR(ierror,routineName);
/* Convert to spherical coordinates */
for (j = 0; j < atmos->Nspace; j++) {
atmos->B[j] = sqrt(SQ(Bx[j]) + SQ(By[j]) + SQ(Bz[j]));
atmos->gamma_B[j] = acos(Bz[j]/atmos->B[j]);
atmos->chi_B[j] = atan(By[j]/Bx[j]);
/* Protect from undefined cases */
if ((Bx[j] == 0) && (By[j] == 0) && (Bz[j] == 0))
atmos->gamma_B[j] = 0.0;
if ((Bx[j] == 0) && (By[j] == 0))
atmos->chi_B[j] = 1.0;
}
free(Bx); free(By); free(Bz);
}
/* allocate and zero nHtot */
atmos->nH = matrix_double(atmos->NHydr, atmos->Nspace);
for (j = 0; j < atmos->Nspace; j++) atmos->nHtot[j] = 0.0;
/* read nH, all at once */
start_nh[0] = input.p15d_nt; count_nh[0] = 1;
start_nh[1] = 0; count_nh[1] = atmos->NHydr;
start_nh[2] = (size_t) xi; count_nh[2] = 1;
start_nh[3] = (size_t) yi; count_nh[3] = 1;
start_nh[4] = mpi.zcut; count_nh[4] = atmos->Nspace;
if ((ierror = nc_get_vara_double(ncid, infile->nh_varid, start_nh, count_nh,
atmos->nH[0]))) ERR(ierror,routineName);
/* Depth grid refinement */
if (input.p15d_refine)
depth_refine(atmos, geometry, input.p15d_tmax);
/* Fix vturb: remove zeros, use multiplier and add */
for (i = 0; i < atmos->Nspace; i++) {
if (atmos->vturb[i] < 0.0) atmos->vturb[i] = 0.0;
atmos->vturb[i] = atmos->vturb[i] * input.vturb_mult + input.vturb_add;
}
/* Sum to get nHtot */
for (i = 0; i < atmos->NHydr; i++){
for (j = 0; j < atmos->Nspace; j++) atmos->nHtot[j] += atmos->nH[i][j];
}
/* Some other housekeeping */
old_moving = atmos->moving;
atmos->moving = FALSE;
for (i = 0; i < atmos->Nspace; i++) {
if (fabs(geometry->vel[i]) >= atmos->vmacro_tresh) {
atmos->moving = TRUE;
/* old_moving should only be false*/
if ((old_moving == FALSE) & (atmos->moving == TRUE)) {
sprintf(messageStr,
"Moving atmosphere detected when the previous column\n"
" (or column [0,0] in file) was not. This will cause problems\n"
" and the code will abort.\n"
" To prevent this situation one can force all columns\n"
" to be moving by setting VMACRO_TRESH = 0 in keyword.input\n");
Error(ERROR_LEVEL_2, routineName, messageStr);
}
break;
}
}
return;
}
Ellipsoid3D CalcErrorEllipsoid(Mtrx3D *pcov, double del_chi_2) {
int ndx, iSwitched;
MatrixDouble A_matrix, V_matrix;
VectorDouble W_vector;
double wtemp, vtemp;
Ellipsoid3D ell;
int ierr = 0;
/* allocate A mtrx */
A_matrix = matrix_double(3, 3);
/* load A matrix in NumRec format */
A_matrix[0][0] = pcov->xx;
A_matrix[0][1] = A_matrix[1][0] = pcov->xy;
A_matrix[0][2] = A_matrix[2][0] = pcov->xz;
A_matrix[1][1] = pcov->yy;
A_matrix[1][2] = A_matrix[2][1] = pcov->yz;
A_matrix[2][2] = pcov->zz;
/* allocate V mtrx and W vector */
V_matrix = matrix_double(3, 3);
W_vector = vector_double(3);
/* do SVD */
//if ((istat = nll_svdcmp0(A_matrix, 3, 3, W_vector, V_matrix)) < 0) {
svd_helper(A_matrix, 3, 3, W_vector, V_matrix);
if (W_vector[0] < SMALL_DOUBLE || W_vector[1] < SMALL_DOUBLE || W_vector[2] < SMALL_DOUBLE) {
fprintf(stderr, "ERROR: invalid SVD singular value for confidence ellipsoids.");
ierr = 1;
} else {
/* sort by singular values W */
iSwitched = 1;
while (iSwitched) {
iSwitched = 0;
for (ndx = 0; ndx < 2; ndx++) {
if (W_vector[ndx] > W_vector[ndx + 1]) {
wtemp = W_vector[ndx];
W_vector[ndx] = W_vector[ndx + 1];
W_vector[ndx + 1] = wtemp;
vtemp = V_matrix[0][ndx];
V_matrix[0][ndx] = V_matrix[0][ndx + 1];
V_matrix[0][ndx + 1] = vtemp;
vtemp = V_matrix[1][ndx];
V_matrix[1][ndx] = V_matrix[1][ndx + 1];
V_matrix[1][ndx + 1] = vtemp;
vtemp = V_matrix[2][ndx];
V_matrix[2][ndx] = V_matrix[2][ndx + 1];
V_matrix[2][ndx + 1] = vtemp;
iSwitched = 1;
}
}
}
/* calculate ellipsoid axes */
/* length: w in Num Rec, 2nd ed, fig 15.6.5 must be replaced
by 1/sqrt(w) since we are using SVD of Cov mtrx and not
SVD of A mtrx (compare eqns 2.6.1 & 15.6.10) */
ell.az1 = atan2(V_matrix[0][0], V_matrix[1][0]) * RA2DE;
if (ell.az1 < 0.0)
ell.az1 += 360.0;
ell.dip1 = asin(V_matrix[2][0]) * RA2DE;
ell.len1 = sqrt(del_chi_2) / sqrt(1.0 / W_vector[0]);
ell.az2 = atan2(V_matrix[0][1], V_matrix[1][1]) * RA2DE;
if (ell.az2 < 0.0)
ell.az2 += 360.0;
ell.dip2 = asin(V_matrix[2][1]) * RA2DE;
ell.len2 = sqrt(del_chi_2) / sqrt(1.0 / W_vector[1]);
ell.len3 = sqrt(del_chi_2) / sqrt(1.0 / W_vector[2]);
}
free_matrix_double(A_matrix, 3, 3);
free_matrix_double(V_matrix, 3, 3);
free_vector_double(W_vector);
if (ierr) {
Ellipsoid3D EllipsoidNULL = {-1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0};
return (EllipsoidNULL);
}
return (ell);
}
/* ------- begin ----------------------------- Escape ------------------- */
void Escape(Atom *atom) {
/*
Calculates radiative rates using the escape probability approximation
Notes: Escape is inserted in an atom loop. Whatever takes place here should be at
atom-only level. Why? Because different atoms can have different starting solutions.
Calling Opacity directly is probably overkill, as it does its own loops, and
works per wavelength, not per atom.
The line opacity has to be per transition, and thus averaged in wavelength.
For bound-bound the procedure is the following:
1. Loop over wavelength to calculate opacity at all wavelengths. Keep an
array for each transition, accumulate there the opacity * wla for each
transition. (this opacity is depth-dependent as well)
2. Loop over transitions (and not wavelength!), calculate tau by integrating
over depth for each transition
3. Once we have tau for each transition, add to the gamma of each transition
(in the same loop) the nrb recipe.
For bound-free the procedure is the following:
1. Calculate intensity only for the relevant wavelenths.
2. Using intensity, calculate proper radiative rates and add them to rate matrix.
Notes for continuum:
* To see how rates are added, look at fillgamma.addtoRates or fillgamma.addtoGamma
* For a simplified version of how to calculate intensity and update rates, look
at formal.c:233 (the angle-independent case). They could be calculated by a single
call of Formal, but there is too much rubbish in the main routine, and it could
call opacity and readbackground more than once -- duplicating many tasks.
*/
const char routineName[] = "Escape";
register int n, k, kr, i, ij, ji, nspect;
int la, j, nt, mu, nact;
double **opa, *chi, *I, *S, *Psi, *Jdag, *J, tau, wlambda, hc_4PI, twohc,
twohnu3_c2, wmu, wlamu, Ieff;
bool_t initialize, to_obs;
ActiveSet *as;
AtomicLine *line;
AtomicContinuum *continuum;
/* --- Some useful constants -- -------------- */
hc_4PI = HPLANCK * CLIGHT / (4.0 * PI);
twohc = 2.0*HPLANCK*CLIGHT / CUBE(NM_TO_M);
opa = matrix_double(atom->Nline, atmos.Nspace);
Jdag = (double *) malloc(atmos.Nspace * sizeof(double));
Psi = (double *) malloc(atmos.Nspace * sizeof(double));
chi = (double *) malloc(atmos.Nspace * sizeof(double));
I = (double *) malloc(atmos.Nspace * sizeof(double));
S = (double *) malloc(atmos.Nspace * sizeof(double));
nact = atom->activeindex;
/* Calculate opacities */
for (nspect = 0; nspect < spectrum.Nspect; nspect++) {
as = spectrum.as + nspect;
alloc_as(nspect, FALSE);
nt = nspect % input.Nthreads;
/* Get line and background opacity */
Opacity(nspect, 0, to_obs=TRUE, initialize=TRUE);
if (input.backgr_in_mem) {
loadBackground(nspect, 0, to_obs=TRUE);
} else {
readBackground(nspect, 0, to_obs=TRUE);
}
/* --- For bound-bound: store opacity in array, per transition -- */
for (kr = 0; kr < atom->Nline; kr++) {
line = atom->line + kr;
la = nspect - line->Nblue;
if (la == 0)
wlambda = getwlambda_line(line, la);
if ((la >= 0) && (la < line->Nlambda)) {
/* increment opacities with each wavelength, multiplying by the
integration weights */
for (k = 0 ; k < atmos.Nspace; k++)
opa[kr][k] += (as->chi[k] + as->chi_c[k]) * (wlambda * line->wphi[k] /
hc_4PI);
}
}
/* --- For bound-free: calculate intensity and update rates ----- */
for (n = 0; n < as->Nactiveatomrt[nact]; n++) {
if (as->art[nact][n].type == ATOMIC_CONTINUUM) {
continuum = as->art[nact][n].ptype.continuum;
la = nspect - continuum->Nblue;
i = continuum->i;
j = continuum->j;
ij = i*atom->Nlevel + j;
ji = j*atom->Nlevel + i;
twohnu3_c2 = twohc / CUBE(spectrum.lambda[nspect]);
/* Use old J and zero new array */
if (input.limit_memory) {
J = (double *) malloc(atmos.Nspace *sizeof(double));
//readJlambda_single(nspect, Jdag);
} else {
J = spectrum.J[nspect];
for (k = 0; k < atmos.Nspace; k++) Jdag[k] = J[k];
}
for (k = 0; k < atmos.Nspace; k++) J[k] = 0.0;
for (mu = 0; mu < atmos.Nrays; mu++) {
wmu = 0.5 * geometry.wmu[mu];
for (k = 0; k < atmos.Nspace; k++) {
chi[k] = as->chi[k] + as->chi_c[k];
S[k] = (as->eta[k] +
as->eta_c[k] + as->sca_c[k]*Jdag[k]) / chi[k];
}
/* Get intensity */
Piecewise_1D(nspect, mu, to_obs=TRUE, chi, S, I, Psi);
/* Update rates */
for (k = 0; k < atmos.Nspace; k++) {
Ieff = I[k] - Psi[k] * atom->rhth[nt].eta[k];
wlamu = atom->rhth[nt].Vij[n][k] * atom->rhth[nt].wla[n][k] * wmu;
atom->Gamma[ji][k] += Ieff * wlamu;
atom->Gamma[ij][k] += (twohnu3_c2 + Ieff) * atom->rhth[nt].gij[n][k] * wlamu;
/* Accumulate mean intensity */
J[k] += wmu * I[k];
}
}
if (input.limit_memory) free(J);
}
}
free_as(nspect, FALSE);
}
/* Bound-bound: calculate optical depth and add approximation to rates */
for (kr = 0; kr < atom->Nline; kr++) {
line = atom->line + kr;
i = line->i;
j = line->j;
ij = i*atom->Nlevel + j;
tau = 0.0;
for (k = 0; k < atmos.Nspace ; k++) {
if (k > 0) {
tau += 0.5*(opa[kr][k-1] + opa[kr][k]) *
(geometry.height[k-1] - geometry.height[k]);
}
/* add escape probability approximation to the rates matrix */
atom->Gamma[ij][k] += line->Aji * Pesc(tau);
}
}
freeMatrix((void **) opa);
free(Jdag);
free(chi);
free(Psi);
free(I);
free(S);
}
void SolveLongStokes(Geometry *geometry, Longchar *lc,
int nspect, int k, int l, int m,
double *chi, double **S, double **I,
double *I_uw)
{
register int ls, n, j;
int local;
double c1, c2, dtau_dw, dS_uw[4], dS_dw[4], w[3],
chi_loc, S_loc[4], dtau_uw, chi_uw, S_uw[4], chi_dw, S_dw[4],
P[4], Q[4][4], **R, K[4][4], K_uw[4][4];
R = matrix_double(4, 4);
/* --- The first point is the intersection with the horizontal
grid line -- -------------- */
chi_uw = Interpolate_3D(chi, geometry, &lc->stencil[0], l, m);
StokesK_3D(nspect, geometry, &lc->stencil[0], l, m, chi_uw, K_uw);
for (n = 0; n < 4; n++) {
S_uw[n] = Interpolate_3D(S[n], geometry, &lc->stencil[0], l, m);
I_uw[n] = Interpolate_3D(I[n], geometry, &lc->stencil[0], l, m);
}
chi_loc = Interpolate_3D(chi, geometry, &lc->stencil[1], l, m);
dtau_uw = 0.5 * (chi_uw + chi_loc) * lc->stencil[0].ds;
StokesK_3D(nspect, geometry, &lc->stencil[1], l, m, chi_loc, K);
for (n = 0; n < 4; n++)
S_loc[n] = Interpolate_3D(S[n], geometry, &lc->stencil[1], l, m);
for (ls = 2; ls < lc->Nst; ls++) {
if (ls == lc->Nst-1) {
/* --- The last point is the the endpoint for which the non-local
contribution is needed. -- -------------- */
local = k*geometry->Nplane + m*geometry->Nx + l;
chi_dw = chi[local];
for (n = 0; n < 4; n++) S_dw[n] = S[n][local];
} else {
chi_dw = Interpolate_3D(chi, geometry, &lc->stencil[ls], l, m);
for (n = 0; n < 4; n++)
S_dw[n] = Interpolate_3D(S[n], geometry, &lc->stencil[ls], l, m);
}
dtau_dw = 0.5 * (chi_loc + chi_dw) * lc->stencil[ls-1].ds;
w3(dtau_uw, w);
for (n = 0; n < 4; n++) {
dS_uw[n] = (S_uw[n] - S_loc[n]) / dtau_uw;
dS_dw[n] = (S_loc[n] - S_dw[n]) / dtau_dw;
c1 = dS_uw[n]*dtau_dw + dS_dw[n]*dtau_uw;
c2 = dS_uw[n] - dS_dw[n];
P[n] = w[0]*S_loc[n] + (w[1]*c1 + w[2]*c2) / (dtau_uw + dtau_dw);
}
for (n = 0; n < 4; n++) {
for (j = 0; j < 4; j++) {
Q[n][j] = -w[1]/dtau_uw * K_uw[n][j];
R[n][j] = (w[0] - w[1]/dtau_uw) * K[n][j];
}
Q[n][n] = 1.0 - w[0];
R[n][n] = 1.0;
}
for (n = 0; n < 4; n++) {
for (j = 0; j < 4; j++)
P[n] += Q[n][j] * I_uw[j];
}
/* --- Solve linear equations for I -- -------------- */
SolveLinearEq(4, R, P, TRUE);
/* --- Store results for the upwind Stokes vector -- ------------ */
for (n = 0; n < 4; n++) I_uw[n] = P[n];
/* --- Reuse upwind quantities -- -------------- */
if (ls < lc->Nst-1) {
chi_uw = chi_loc;
chi_loc = chi_dw;
dtau_uw = dtau_dw;
for (n = 0; n < 4; n++) {
S_uw[n] = S_loc[n];
S_loc[n] = S_dw[n];
for (j = 0; j < 4; j++) K_uw[n][j] = K[n][j];
}
StokesK_3D(nspect, geometry, &lc->stencil[ls], l, m, chi_dw, K);
}
}
freeMatrix((void **) R);
}
void MULTIatmos(Atmosphere *atmos, Geometry *geometry)
{
const char routineName[] = "MULTIatmos";
register int k, n, mu;
char scaleStr[20], inputLine[MAX_LINE_SIZE], *filename;
bool_t exit_on_EOF, enhanced_atmos_ID = FALSE;
int Nread, Ndep, Nrequired, checkPoint;
double *dscale, turbpress, turbelecpress, nbaryon, meanweight;
struct stat statBuffer;
getCPU(2, TIME_START, NULL);
/* --- Get abundances of background elements -- ------------ */
readAbundance(atmos);
/* --- Open the input file for model atmosphere in MULTI format - - */
if ((atmos->fp_atmos = fopen(input.atmos_input, "r")) == NULL) {
sprintf(messageStr, "Unable to open inputfile %s", input.atmos_input);
Error(ERROR_LEVEL_2, routineName, messageStr);
} else {
sprintf(messageStr, "\n -- reading input file: %s\n\n",
input.atmos_input);
Error(MESSAGE, NULL, messageStr);
}
atmos->NHydr = N_HYDROGEN_MULTI;
/* --- Boundary condition at TOP of atmosphere -- ------------ */
if (strcmp(input.Itop, "none"))
geometry->vboundary[TOP] = IRRADIATED;
else
geometry->vboundary[TOP] = ZERO;
/* --- Boundary condition at BOTTOM of atmosphere -- ------------ */
geometry->vboundary[BOTTOM] = THERMALIZED;
/* --- Read atmos ID, scale type, gravity, and number of depth
points -- ------------ */
getLine(atmos->fp_atmos, MULTI_COMMENT_CHAR, inputLine, exit_on_EOF=TRUE);
if (enhanced_atmos_ID) {
/* --- Construct atmosID from filename and last modification date */
stat(input.atmos_input, &statBuffer);
if ((filename = strrchr(input.atmos_input, '/')) != NULL)
filename++;
else
filename = input.atmos_input;
sprintf(atmos->ID, "%s (%.24s)", filename,
asctime(localtime(&statBuffer.st_mtime)));
Nread = 1;
} else
Nread = sscanf(inputLine, "%s", atmos->ID);
getLine(atmos->fp_atmos, MULTI_COMMENT_CHAR, inputLine, exit_on_EOF=TRUE);
Nread += sscanf(inputLine, "%20s", scaleStr);
getLine(atmos->fp_atmos, MULTI_COMMENT_CHAR, inputLine, exit_on_EOF=TRUE);
Nread += sscanf(inputLine, "%lf", &atmos->gravity);
getLine(atmos->fp_atmos, MULTI_COMMENT_CHAR, inputLine, exit_on_EOF=TRUE);
Nread += sscanf(inputLine, "%d", &geometry->Ndep);
checkNread(Nread, Nrequired=4, routineName, checkPoint=1);
/* --- Keep duplicates of some of the geometrical quantities in
Atmos structure -- -------------- */
atmos->Ndim = 1;
atmos->N = (int *) malloc(atmos->Ndim * sizeof(int));
atmos->Nspace = Ndep = geometry->Ndep;
atmos->N[0] = Ndep;
atmos->gravity = POW10(atmos->gravity) * CM_TO_M;
/* --- Allocate space for arrays that define structure -- --------- */
geometry->tau_ref = (double *) malloc(Ndep * sizeof(double));
geometry->cmass = (double *) malloc(Ndep * sizeof(double));
geometry->height = (double *) malloc(Ndep * sizeof(double));
atmos->T = (double *) malloc(Ndep * sizeof(double));
atmos->ne = (double *) malloc(Ndep * sizeof(double));
atmos->vturb = (double *) malloc(Ndep * sizeof(double));
geometry->vel = (double *) malloc(Ndep * sizeof(double));
dscale = (double *) malloc(Ndep * sizeof(double));
for (k = 0; k < Ndep; k++) {
getLine(atmos->fp_atmos, MULTI_COMMENT_CHAR, inputLine, exit_on_EOF=TRUE);
Nread = sscanf(inputLine, "%lf %lf %lf %lf %lf",
&dscale[k], &atmos->T[k], &atmos->ne[k],
&geometry->vel[k], &atmos->vturb[k]);
checkNread(Nread, Nrequired=5, routineName, checkPoint=2);
}
switch(toupper(scaleStr[0])) {
case 'M':
geometry->scale = COLUMN_MASS;
for (k = 0; k < Ndep; k++)
geometry->cmass[k] = POW10(dscale[k]) * (G_TO_KG / SQ(CM_TO_M));
break;
case 'T':
geometry->scale = TAU500;
for (k = 0; k < Ndep; k++) geometry->tau_ref[k] = POW10(dscale[k]);
break;
case 'H':
geometry->scale = GEOMETRIC;
for (k = 0; k < Ndep; k++) geometry->height[k] = dscale[k] * KM_TO_M;
break;
default:
sprintf(messageStr, "Unknown depth scale string in file %s: %s",
input.atmos_input, scaleStr);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
free(dscale);
for (k = 0; k < Ndep; k++) {
geometry->vel[k] *= KM_TO_M;
atmos->vturb[k] *= KM_TO_M;
atmos->ne[k] /= CUBE(CM_TO_M);
}
atmos->moving = FALSE;
for (k = 0; k < Ndep; k++) {
if (fabs(geometry->vel[k]) >= atmos->vmacro_tresh) {
atmos->moving = TRUE;
break;
}
}
/* --- Get angle-quadrature and copy geometry independent quantity
wmu to atmos structure. -- -------------- */
getAngleQuad(geometry);
atmos->wmu = geometry->wmu;
/* --- Magnetic field is read here. -- -------------- */
atmos->Stokes = readB(atmos);
/* --- Read Hydrogen populations if present -- -------------- */
atmos->nH = matrix_double(atmos->NHydr, Ndep);
for (k = 0; k < Ndep; k++) {
if (getLine(atmos->fp_atmos, MULTI_COMMENT_CHAR, inputLine,
exit_on_EOF=FALSE) == EOF) break;
Nread = sscanf(inputLine, "%lf %lf %lf %lf %lf %lf",
&atmos->nH[0][k], &atmos->nH[1][k], &atmos->nH[2][k],
&atmos->nH[3][k], &atmos->nH[4][k], &atmos->nH[5][k]);
checkNread(Nread, Nrequired=6, routineName, checkPoint=3);
}
if (k > 0 && k < Ndep) {
sprintf(messageStr,
"Reached end of input file %s before all data was read",
input.atmos_input);
Error(ERROR_LEVEL_2, routineName, messageStr);
} else if (k == 0) {
/* --- No hydrogen populations supplied: use LTE populations
like MULTI does -- -------------- */
if (geometry->scale != COLUMN_MASS) {
sprintf(messageStr,
"Height scale should be COLUMNMASS when nH not supplied: "
"File %s", input.atmos_input);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
atmos->nHtot = (double *) calloc(Ndep, sizeof(double));
atmos->H_LTE = TRUE;
meanweight = atmos->avgMolWght * AMU;
for (k = 0; k < Ndep; k++) {
turbpress = 0.5 * meanweight * SQ(atmos->vturb[k]);
turbelecpress = 0.5 * M_ELECTRON * SQ(atmos->vturb[k]);
nbaryon =
(atmos->gravity * geometry->cmass[k] -
atmos->ne[k] *(KBOLTZMANN * atmos->T[k] + turbelecpress));
atmos->nHtot[k] = nbaryon /
(atmos->totalAbund * (KBOLTZMANN * atmos->T[k] + turbpress));
}
} else if (k == Ndep) {
atmos->nHtot = (double *) calloc(Ndep, sizeof(double));
for (n = 0; n < atmos->NHydr; n++) {
for (k = 0; k < Ndep; k++) {
atmos->nH[n][k] /= CUBE(CM_TO_M);
atmos->nHtot[k] += atmos->nH[n][k];
}
}
}
getCPU(2, TIME_POLL, "Read Atmosphere");
}
bool_t readBarklemTable(enum Barklemtype type, Barklemstruct *bs)
{
register int n, i, j;
const char routineName[] = "readBarklemTable";
char filename[MAX_LINE_SIZE], inputLine[MAX_LINE_SIZE], *charptr;
int nread;
double neff1_0, neff2_0;
FILE *fp_Barklem;
switch (type) {
case SP:
strcpy(filename, BARKLEM_SP_DATA);
bs->N1 = BARKLEM_SP_NS;
bs->N2 = BARKLEM_SP_NP;
neff1_0 = BARKLEM_SP_NEFF1;
neff2_0 = BARKLEM_SP_NEFF2;
break;
case PD:
strcpy(filename, BARKLEM_PD_DATA);
bs->N1 = BARKLEM_PD_NP;
bs->N2 = BARKLEM_PD_ND;
neff1_0 = BARKLEM_PD_NEFF1;
neff2_0 = BARKLEM_PD_NEFF2;
break;
case DF:
strcpy(filename, BARKLEM_DF_DATA);
bs->N1 = BARKLEM_DF_ND;
bs->N2 = BARKLEM_DF_NF;
neff1_0 = BARKLEM_DF_NEFF1;
neff2_0 = BARKLEM_DF_NEFF2;
break;
}
if ((fp_Barklem = fopen(filename, "r")) == NULL) {
sprintf(messageStr, "Unable to open input file %s", filename);
Error(ERROR_LEVEL_1, routineName, messageStr);
return FALSE;
}
bs->neff1 = (double *) malloc(bs->N1 * sizeof(double));
for (n = 0; n < bs->N1; n++)
bs->neff1[n] = neff1_0 + n * BARKLEM_DELTA_NEFF;
bs->neff2 = (double *) malloc(bs->N2 * sizeof(double));
for (n = 0; n < bs->N2; n++)
bs->neff2[n] = neff2_0 + n * BARKLEM_DELTA_NEFF;
bs->cross = matrix_double(bs->N1, bs->N2);
bs->alpha = matrix_double(bs->N1, bs->N2);
for (n = 0; n < 3; n++)
charptr = fgets(inputLine, MAX_LINE_SIZE, fp_Barklem);
for (i = 0; i < bs->N1; i++)
for (j = 0; j < bs->N2; j++) {
nread = fscanf(fp_Barklem, "%lf", &bs->cross[i][j]);
}
for (n = 0; n < 2; n++)
charptr = fgets(inputLine, MAX_LINE_SIZE, fp_Barklem);
for (i = 0; i < bs->N1; i++)
for (j = 0; j < bs->N2; j++) {
nread = fscanf(fp_Barklem, "%lf", &bs->alpha[i][j]);
}
fclose(fp_Barklem);
return TRUE;
}
void statEquil(Atom *atom, int isum)
{
register int i, j, ij, k;
int i_eliminate, Nlevel;
double GamDiag, nmax_k, *n_k, **Gamma_k;
getCPU(3, TIME_START, NULL);
Nlevel = atom->Nlevel;
/* --- Need temporary storage because Gamma has to be solved spatial
point by spatial point while depth is normally the fastest
running index -- -------------- */
n_k = (double *) malloc(Nlevel * sizeof(double));
Gamma_k = matrix_double(Nlevel, Nlevel);
for (k = 0; k < atmos.Nspace; k++) {
for (i = 0, ij = 0; i < Nlevel; i++) {
n_k[i] = atom->n[i][k];
for (j = 0; j < Nlevel; j++, ij++)
Gamma_k[i][j] = atom->Gamma[ij][k];
}
if (isum == -1) {
i_eliminate = 0;
nmax_k = 0.0;
for (i = 0; i < Nlevel; i++) {
if (n_k[i] > nmax_k) {
nmax_k = n_k[i];
i_eliminate = i;
}
}
} else
i_eliminate = isum;
/* --- For each column i sum over rows to get diagonal elements - */
for (i = 0; i < Nlevel; i++) {
GamDiag = 0.0;
Gamma_k[i][i] = 0.0;
n_k[i] = 0.0;
for (j = 0; j < Nlevel; j++) GamDiag += Gamma_k[j][i];
Gamma_k[i][i] = -GamDiag;
}
/* --- Close homogeneous set with particle conservation-- ------- */
n_k[i_eliminate] = atom->ntotal[k];
for (j = 0; j < Nlevel; j++) Gamma_k[i_eliminate][j] = 1.0;
/* --- Solve for new population numbers at location k -- -------- */
SolveLinearEq(Nlevel, Gamma_k, n_k, TRUE);
if (mpi.stop) {
free(n_k);
freeMatrix((void **) Gamma_k);
return; /* Get out if there is a singular matrix */
}
for (i = 0; i < Nlevel; i++) atom->n[i][k] = n_k[i];
}
free(n_k);
freeMatrix((void **) Gamma_k);
getCPU(3, TIME_POLL, "Stat Equil");
}
void ASENSOR::VoltsDoubleToColumnVector( double v[], matrix &V )
{
V.dim(1,DAQ_ChannelCount);
matrix_double(v,V);
}
void SolveShortStokes(Geometry *geometry, Stencil *st_uw, Stencil *st_dw,
int nspect, int k, int kend, int l, int m,
double *I_uw,
double *chi, double **S, double **I, double *Psi)
{
/* --- Piecewise integration of the coupled Stokes transfer equations
in two dimensions. Method is quasi-parabolic DELO method.
See: - D. E. Rees, G. A. Murphy and C. J. Durrant 1989, ApJ 339,
1093-1106.
- H. Socas Navarro, J. Trujillo Bueno and B. Ruiz Cobo 2000,
"Non-LTE Inversion of Stokes Profiles", ApJ 530, 977.
-- -------------- */
register int n, j;
int local;
double chi_uw, chi_dw, S_uw[4], S_dw[4], dS_dw[4], dS_uw[4],
dtau_uw, dtau_dw, w[3], c1, c2, P[4], Q[4][4], **R,
K[4][4], K_uw[4][4];
R = matrix_double(4, 4);
local = k*geometry->Nplane + m*geometry->Nx + l;
/* --- The upwind quantities -- -------------- */
chi_uw = Interpolate_3D(chi, geometry, st_uw, l, m);
dtau_uw = 0.5 * (chi_uw + chi[local]) * st_uw->ds;
StokesK_3D(nspect, geometry, st_uw, l, m, chi_uw, K_uw);
for (n = 0; n < 4; n++) {
S_uw[n] = Interpolate_3D(S[n], geometry, st_uw, l, m);
dS_uw[n] = (S_uw[n] - S[n][local]) / dtau_uw;
}
StokesK(nspect, local, chi[local], K);
if (k == kend) {
w2(dtau_uw, w);
/* --- Piecewise linear integration in last layer -- ------------ */
for (n = 0; n < 4; n++) {
c1 = (S_uw[n] - S[n][local]) / dtau_uw;
P[n] = w[0]*S[n][local] + w[1]*dS_uw[n];
}
if (Psi) Psi[local] = w[0] - w[1]/dtau_uw;
} else {
w3(dtau_uw, w);
/* --- The downwind quantities -- -------------- */
chi_dw = Interpolate_3D(chi, geometry, st_dw, l, m);
dtau_dw = 0.5 * (chi[local] + chi_dw) * st_dw->ds;
/* --- Piecewise quadratic integration -- -------------- */
for (n = 0; n < 4; n++) {
S_dw[n] = Interpolate_3D(S[n], geometry, st_dw, l, m);
dS_dw[n] = (S[n][local] - S_dw[n]) / dtau_dw;
c1 = dS_uw[n]*dtau_dw + dS_dw[n]*dtau_uw;
c2 = dS_uw[n] - dS_dw[n];
P[n] = w[0]*S[n][local] + (w[1]*c1 + w[2]*c2) /
(dtau_uw + dtau_dw);
}
if (Psi) {
c1 = dtau_uw - dtau_dw;
Psi[local] = w[0] + (w[1]*c1 - w[2]) / (dtau_uw * dtau_dw);
}
}
for (n = 0; n < 4; n++) {
for (j = 0; j < 4; j++) {
Q[n][j] = -w[1]/dtau_uw * K_uw[n][j];
R[n][j] = (w[0] - w[1]/dtau_uw) * K[n][j];
}
Q[n][n] = 1.0 - w[0];
R[n][n] = 1.0;
}
for (n = 0; n < 4; n++) {
for (j = 0; j < 4; j++)
P[n] += Q[n][j] * I_uw[j];
}
/* --- Solve linear equations for I -- -------------- */
SolveLinearEq(4, R, P, TRUE);
/* --- Store results for Stokes vector -- -------------- */
for (n = 0; n < 4; n++) I[n][local] = P[n];
freeMatrix((void **) R);
}
/**
Constructs and returns a new singular value decomposition object;
The decomposed matrices can be retrieved via instance methods of the returned decomposition object.
@param A A rectangular matrix.
@return A decomposition object to access <tt>U</tt>, <tt>S</tt> and <tt>V</tt>.
@throws IllegalArgumentException if <tt>A.rows() < A.columns()</tt>.
*/
void SingularValueDecomposition(MatrixDouble A_matrix_orig, int nrows, int ncolumns) {
int i, j, k;
//Property.DEFAULT.checkRectangular(Arg);
// Derived from LINPACK code.
// Initialize.
num_rows = nrows;
num_columns = ncolumns;
// make local copy of original A matrix
MatrixDouble A_matrix = matrix_double(num_rows, num_columns);
for (i = 0; i < num_rows; i++) {
for (j = 0; j < num_columns; j++) {
A_matrix[i][j] = A_matrix_orig[i][j];
}
}
clean_SingularValueDecomposition();
int nu = Math_min(num_rows, num_columns);
singular_values = vector_double(Math_min(num_rows + 1, num_columns));
U_matrix = matrix_double(num_rows, nu);
V_matrix = matrix_double(num_columns, num_columns);
double *e = calloc(num_columns, sizeof (double));
double *work = calloc(num_rows, sizeof (double));
int wantu = 1;
int wantv = 1;
// Reduce A to bidiagonal form, storing the diagonal elements
// in s and the super-diagonal elements in e.
int nct = Math_min(num_rows - 1, num_columns);
int nrt = Math_max(0, Math_min(num_columns - 2, num_rows));
for (k = 0; k < Math_max(nct, nrt); k++) {
if (k < nct) {
// Compute the transformation for the k-th column and
// place the k-th diagonal in s[k].
// Compute 2-norm of k-th column without under/overflow.
singular_values[k] = 0;
for (i = k; i < num_rows; i++) {
singular_values[k] = Algebra_hypot(singular_values[k], A_matrix[i][k]);
}
if (singular_values[k] != 0.0) {
if (A_matrix[k][k] < 0.0) {
singular_values[k] = -singular_values[k];
}
for (i = k; i < num_rows; i++) {
A_matrix[i][k] /= singular_values[k];
}
A_matrix[k][k] += 1.0;
}
singular_values[k] = -singular_values[k];
}
for (j = k + 1; j < num_columns; j++) {
if ((k < nct) & (singular_values[k] != 0.0)) {
// Apply the transformation.
double t = 0;
for (i = k; i < num_rows; i++) {
t += A_matrix[i][k] * A_matrix[i][j];
}
t = -t / A_matrix[k][k];
for (i = k; i < num_rows; i++) {
A_matrix[i][j] += t * A_matrix[i][k];
}
}
// Place the k-th row of A into e for the
// subsequent calculation of the row transformation.
e[j] = A_matrix[k][j];
}
if (wantu & (k < nct)) {
// Place the transformation in U for subsequent back
// multiplication.
for (i = k; i < num_rows; i++) {
U_matrix[i][k] = A_matrix[i][k];
}
}
if (k < nrt) {
// Compute the k-th row transformation and place the
// k-th super-diagonal in e[k].
// Compute 2-norm without under/overflow.
e[k] = 0;
for (i = k + 1; i < num_columns; i++) {
e[k] = Algebra_hypot(e[k], e[i]);
}
if (e[k] != 0.0) {
if (e[k + 1] < 0.0) {
e[k] = -e[k];
}
for (i = k + 1; i < num_columns; i++) {
e[i] /= e[k];
}
e[k + 1] += 1.0;
}
e[k] = -e[k];
if ((k + 1 < num_rows) & (e[k] != 0.0)) {
// Apply the transformation.
for (i = k + 1; i < num_rows; i++) {
work[i] = 0.0;
}
for (j = k + 1; j < num_columns; j++) {
for (i = k + 1; i < num_rows; i++) {
work[i] += e[j] * A_matrix[i][j];
}
}
for (j = k + 1; j < num_columns; j++) {
double t = -e[j] / e[k + 1];
for (i = k + 1; i < num_rows; i++) {
A_matrix[i][j] += t * work[i];
}
}
}
if (wantv) {
// Place the transformation in V for subsequent
// back multiplication.
for (i = k + 1; i < num_columns; i++) {
V_matrix[i][k] = e[i];
}
}
}
}
// Set up the final bidiagonal matrix or order p.
int p = Math_min(num_columns, num_rows + 1);
if (nct < num_columns) {
singular_values[nct] = A_matrix[nct][nct];
}
if (num_rows < p) {
singular_values[p - 1] = 0.0;
}
if (nrt + 1 < p) {
e[nrt] = A_matrix[nrt][p - 1];
}
e[p - 1] = 0.0;
// If required, generate U.
if (wantu) {
for (j = nct; j < nu; j++) {
for (i = 0; i < num_rows; i++) {
U_matrix[i][j] = 0.0;
}
U_matrix[j][j] = 1.0;
}
for (k = nct - 1; k >= 0; k--) {
if (singular_values[k] != 0.0) {
for (j = k + 1; j < nu; j++) {
double t = 0;
for (i = k; i < num_rows; i++) {
t += U_matrix[i][k] * U_matrix[i][j];
}
t = -t / U_matrix[k][k];
for (i = k; i < num_rows; i++) {
U_matrix[i][j] += t * U_matrix[i][k];
}
}
for (i = k; i < num_rows; i++) {
U_matrix[i][k] = -U_matrix[i][k];
}
U_matrix[k][k] = 1.0 + U_matrix[k][k];
for (i = 0; i < k - 1; i++) {
U_matrix[i][k] = 0.0;
}
} else {
for (i = 0; i < num_rows; i++) {
U_matrix[i][k] = 0.0;
}
U_matrix[k][k] = 1.0;
}
}
}
// If required, generate V.
if (wantv) {
for (k = num_columns - 1; k >= 0; k--) {
if ((k < nrt) & (e[k] != 0.0)) {
for (j = k + 1; j < nu; j++) {
double t = 0;
for (i = k + 1; i < num_columns; i++) {
t += V_matrix[i][k] * V_matrix[i][j];
}
t = -t / V_matrix[k + 1][k];
for (i = k + 1; i < num_columns; i++) {
V_matrix[i][j] += t * V_matrix[i][k];
}
}
}
for (i = 0; i < num_columns; i++) {
V_matrix[i][k] = 0.0;
}
V_matrix[k][k] = 1.0;
}
}
// Main iteration loop for the singular values.
int pp = p - 1;
int iter = 0;
double eps = pow(2.0, -52.0);
while (p > 0) {
int k, kase;
// Here is where a test for too many iterations would go.
// This section of the program inspects for
// negligible elements in the s and e arrays. On
// completion the variables kase and k are set as follows.
// kase = 1 if s(p) and e[k-1] are negligible and k<p
// kase = 2 if s(k) is negligible and k<p
// kase = 3 if e[k-1] is negligible, k<p, and
// s(k), ..., s(p) are not negligible (qr step).
// kase = 4 if e(p-1) is negligible (convergence).
for (k = p - 2; k >= -1; k--) {
if (k == -1) {
break;
}
if (fabs(e[k]) <= eps * (fabs(singular_values[k]) + fabs(singular_values[k + 1]))) {
e[k] = 0.0;
break;
}
}
if (k == p - 2) {
kase = 4;
} else {
int ks;
for (ks = p - 1; ks >= k; ks--) {
if (ks == k) {
break;
}
double t = (ks != p ? fabs(e[ks]) : 0.) +
(ks != k + 1 ? fabs(e[ks - 1]) : 0.);
if (fabs(singular_values[ks]) <= eps * t) {
singular_values[ks] = 0.0;
break;
}
}
if (ks == k) {
kase = 3;
} else if (ks == p - 1) {
kase = 1;
} else {
kase = 2;
k = ks;
}
}
k++;
// Perform the task indicated by kase.
switch (kase) {
// Deflate negligible s(p).
case 1:
{
double f = e[p - 2];
e[p - 2] = 0.0;
for (j = p - 2; j >= k; j--) {
double t = Algebra_hypot(singular_values[j], f);
double cs = singular_values[j] / t;
double sn = f / t;
singular_values[j] = t;
if (j != k) {
f = -sn * e[j - 1];
e[j - 1] = cs * e[j - 1];
}
if (wantv) {
for (i = 0; i < num_columns; i++) {
t = cs * V_matrix[i][j] + sn * V_matrix[i][p - 1];
V_matrix[i][p - 1] = -sn * V_matrix[i][j] + cs * V_matrix[i][p - 1];
V_matrix[i][j] = t;
}
}
}
}
break;
// Split at negligible s(k).
case 2:
{
double f = e[k - 1];
e[k - 1] = 0.0;
for (j = k; j < p; j++) {
double t = Algebra_hypot(singular_values[j], f);
double cs = singular_values[j] / t;
double sn = f / t;
singular_values[j] = t;
f = -sn * e[j];
e[j] = cs * e[j];
if (wantu) {
for (i = 0; i < num_rows; i++) {
t = cs * U_matrix[i][j] + sn * U_matrix[i][k - 1];
U_matrix[i][k - 1] = -sn * U_matrix[i][j] + cs * U_matrix[i][k - 1];
U_matrix[i][j] = t;
}
}
}
}
break;
// Perform one qr step.
case 3:
{
// Calculate the shift.
double scale = Math_max(Math_max(Math_max(Math_max(
fabs(singular_values[p - 1]), fabs(singular_values[p - 2])), fabs(e[p - 2])),
fabs(singular_values[k])), fabs(e[k]));
double sp = singular_values[p - 1] / scale;
double spm1 = singular_values[p - 2] / scale;
double epm1 = e[p - 2] / scale;
double sk = singular_values[k] / scale;
double ek = e[k] / scale;
double b = ((spm1 + sp)*(spm1 - sp) + epm1 * epm1) / 2.0;
double c = (sp * epm1)*(sp * epm1);
double shift = 0.0;
if ((b != 0.0) | (c != 0.0)) {
shift = sqrt(b * b + c);
if (b < 0.0) {
shift = -shift;
}
shift = c / (b + shift);
}
double f = (sk + sp)*(sk - sp) + shift;
double g = sk*ek;
// Chase zeros.
for (j = k; j < p - 1; j++) {
double t = Algebra_hypot(f, g);
double cs = f / t;
double sn = g / t;
if (j != k) {
e[j - 1] = t;
}
f = cs * singular_values[j] + sn * e[j];
e[j] = cs * e[j] - sn * singular_values[j];
g = sn * singular_values[j + 1];
singular_values[j + 1] = cs * singular_values[j + 1];
if (wantv) {
for (i = 0; i < num_columns; i++) {
t = cs * V_matrix[i][j] + sn * V_matrix[i][j + 1];
V_matrix[i][j + 1] = -sn * V_matrix[i][j] + cs * V_matrix[i][j + 1];
V_matrix[i][j] = t;
}
}
t = Algebra_hypot(f, g);
cs = f / t;
sn = g / t;
singular_values[j] = t;
f = cs * e[j] + sn * singular_values[j + 1];
singular_values[j + 1] = -sn * e[j] + cs * singular_values[j + 1];
g = sn * e[j + 1];
e[j + 1] = cs * e[j + 1];
if (wantu && (j < num_rows - 1)) {
for (i = 0; i < num_rows; i++) {
t = cs * U_matrix[i][j] + sn * U_matrix[i][j + 1];
U_matrix[i][j + 1] = -sn * U_matrix[i][j] + cs * U_matrix[i][j + 1];
U_matrix[i][j] = t;
}
}
}
e[p - 2] = f;
iter = iter + 1;
}
break;
// Convergence.
case 4:
{
// Make the singular values positive.
if (singular_values[k] <= 0.0) {
singular_values[k] = (singular_values[k] < 0.0 ? -singular_values[k] : 0.0);
if (wantv) {
for (i = 0; i <= pp; i++) {
V_matrix[i][k] = -V_matrix[i][k];
}
}
}
// Order the singular values.
while (k < pp) {
if (singular_values[k] >= singular_values[k + 1]) {
break;
}
double t = singular_values[k];
singular_values[k] = singular_values[k + 1];
singular_values[k + 1] = t;
if (wantv && (k < num_columns - 1)) {
for (i = 0; i < num_columns; i++) {
t = V_matrix[i][k + 1];
V_matrix[i][k + 1] = V_matrix[i][k];
V_matrix[i][k] = t;
}
}
if (wantu && (k < num_rows - 1)) {
for (i = 0; i < num_rows; i++) {
t = U_matrix[i][k + 1];
U_matrix[i][k + 1] = U_matrix[i][k];
U_matrix[i][k] = t;
}
}
k++;
}
iter = 0;
p--;
}
break;
}
}
// clean up
free(e);
e = NULL;
free(work);
work = NULL;
free_matrix_double(A_matrix, num_rows, nu);
}
void distribute_nH()
{
const char routineName[] = "distribute_nH";
register int k, i;
char config[4], *ptr;
int *quantumNo, iq;
long Nspace = atmos.Nspace;
double *g_total, g_i;
/* --- Redistribute the hydrogen levels for use in the background
opacity package.
Use the following conventions:
1 -- To save memory:
- let atmos.np point to atmos.H.n[atmos.H.Nlevel-1]
- let nH2 point to atmos.molecules[0].n;
2 -- atmos.nHtot represents the total number of hydrogen
atoms in neutral atoms, protons, H-, and H2 and H2+
molecules. So in general atmos.nHtot != atmos.H.ntotal.
3 -- In case of LTE (set by atmos.H_LTE, see keyword.input)
let atmos.H.n point to the LTE equivalents atmos.H.nstar.
-- -------------- */
if (atmos.H_LTE) {
atmos.H->NLTEpops = FALSE;
Error(MESSAGE, routineName,
"\nUsing LTE hydrogen populations for background opacities\n\n");
/* --- To save memory space let atmos.H->n point to LTE populations
atmos.H->nstar -- -------------- */
if (!atmos.H->active)
atmos.H->n = atmos.H->nstar;
else {
for (i = 0; i < atmos.H->Nlevel; i++) {
for (k = 0; k < Nspace; k++)
atmos.H->n[i][k] = atmos.H->nstar[i][k];
}
}
} else {
atmos.H->NLTEpops = TRUE;
if (!atmos.H->active)
atmos.H->n = matrix_double(atmos.H->Nlevel, atmos.Nspace);
/* --- Find principal quantum number from label -- ------------ */
quantumNo = (int *) malloc((atmos.H->Nlevel - 1) * sizeof(int));
g_total = (double *) calloc(atmos.NHydr - 1, sizeof(double));
for (i = 0; i < atmos.H->Nlevel-1; i++) {
sscanf(atmos.H->label[i], "H I %s", config);
ptr = config; while (isdigit(*ptr)) ptr++; *ptr = ' ';
sscanf(config, "%d", &quantumNo[i]);
if (quantumNo[i] < atmos.NHydr)
g_total[quantumNo[i] - 1] += atmos.H->g[i];
}
/* --- Now redistribute atmosphere's Hydrogen populations over
the levels of atom H -- -------------- */
for (i = 0; i < atmos.H->Nlevel-1; i++) {
if (quantumNo[i] < atmos.NHydr) {
iq = quantumNo[i] - 1;
g_i = atmos.H->g[i] / g_total[iq];
for (k = 0; k < Nspace; k++)
atmos.H->n[i][k] = g_i * atmos.nH[iq][k];
} else {
sprintf(messageStr, "Too many hydrogen levels (level n = %d)\n"
" Background opacity additional levels set to zero%s",
quantumNo[i], (i == atmos.H->Nlevel-2) ? "\n\n" : "");
Error(WARNING, routineName, messageStr);
}
}
free(quantumNo); free(g_total);
/* --- The protons come last -- -------------- */
for (k = 0; k < Nspace; k++)
atmos.H->n[atmos.H->Nlevel-1][k] = atmos.nH[atmos.NHydr-1][k];
}
/* --- Free memory for atmospheric populations -- -------------- */
freeMatrix((void **) atmos.nH);
}
int
main( int argc, char *argv[] )
{
extern void dummy( void * );
float aa, *a, *b, *c, *x, *y;
double aad, *ad, *bd, *cd, *xd, *yd;
int i, j, n;
int inner = 0;
int vector = 0;
int matrix = 0;
int double_precision = 0;
int retval = PAPI_OK;
char papi_event_str[PAPI_MIN_STR_LEN] = "PAPI_FP_OPS";
int papi_event;
int EventSet = PAPI_NULL;
/* Parse the input arguments */
for ( i = 0; i < argc; i++ ) {
if ( strstr( argv[i], "-i" ) )
inner = 1;
else if ( strstr( argv[i], "-v" ) )
vector = 1;
else if ( strstr( argv[i], "-m" ) )
matrix = 1;
else if ( strstr( argv[i], "-e" ) ) {
if ( ( argv[i + 1] == NULL ) || ( strlen( argv[i + 1] ) == 0 ) ) {
print_help( argv );
exit( 1 );
}
strncpy( papi_event_str, argv[i + 1], sizeof ( papi_event_str ) );
i++;
} else if ( strstr( argv[i], "-d" ) )
double_precision = 1;
else if ( strstr( argv[i], "-h" ) ) {
print_help( argv );
exit( 1 );
}
}
/* if no options specified, set all tests to TRUE */
if ( inner + vector + matrix == 0 )
inner = vector = matrix = 1;
tests_quiet( argc, argv ); /* Set TESTS_QUIET variable */
if ( !TESTS_QUIET )
printf( "Initializing..." );
/* Initialize PAPI */
retval = PAPI_library_init( PAPI_VER_CURRENT );
if ( retval != PAPI_VER_CURRENT )
test_fail( __FILE__, __LINE__, "PAPI_library_init", retval );
/* Translate name */
retval = PAPI_event_name_to_code( papi_event_str, &papi_event );
if ( retval != PAPI_OK )
test_fail( __FILE__, __LINE__, "PAPI_event_name_to_code", retval );
if ( PAPI_query_event( papi_event ) != PAPI_OK )
test_skip( __FILE__, __LINE__, "PAPI_query_event", PAPI_ENOEVNT );
if ( ( retval = PAPI_create_eventset( &EventSet ) ) != PAPI_OK )
test_fail( __FILE__, __LINE__, "PAPI_create_eventset", retval );
if ( ( retval = PAPI_add_event( EventSet, papi_event ) ) != PAPI_OK )
test_fail( __FILE__, __LINE__, "PAPI_add_event", retval );
printf( "\n" );
retval = PAPI_OK;
/* Inner Product test */
if ( inner ) {
/* Allocate the linear arrays */
if (double_precision) {
xd = malloc( INDEX5 * sizeof(double) );
yd = malloc( INDEX5 * sizeof(double) );
if ( !( xd && yd ) )
retval = PAPI_ENOMEM;
}
else {
x = malloc( INDEX5 * sizeof(float) );
y = malloc( INDEX5 * sizeof(float) );
if ( !( x && y ) )
retval = PAPI_ENOMEM;
}
if ( retval == PAPI_OK ) {
headerlines( "Inner Product Test", TESTS_QUIET );
/* step through the different array sizes */
for ( n = 0; n < INDEX5; n++ ) {
if ( n < INDEX1 || ( ( n + 1 ) % 50 ) == 0 ) {
/* Initialize the needed arrays at this size */
if ( double_precision ) {
for ( i = 0; i <= n; i++ ) {
xd[i] = ( double ) rand( ) * ( double ) 1.1;
yd[i] = ( double ) rand( ) * ( double ) 1.1;
}
} else {
for ( i = 0; i <= n; i++ ) {
x[i] = ( float ) rand( ) * ( float ) 1.1;
y[i] = ( float ) rand( ) * ( float ) 1.1;
}
}
/* reset PAPI flops count */
reset_flops( "Inner Product Test", EventSet );
/* do the multiplication */
if ( double_precision ) {
aad = inner_double( n, xd, yd );
dummy( ( void * ) &aad );
} else {
aa = inner_single( n, x, y );
dummy( ( void * ) &aa );
}
resultline( n, 1, EventSet );
}
}
}
if (double_precision) {
free( xd );
free( yd );
} else {
free( x );
free( y );
}
}
/* Matrix Vector test */
if ( vector && retval != PAPI_ENOMEM ) {
/* Allocate the needed arrays */
if (double_precision) {
ad = malloc( INDEX5 * INDEX5 * sizeof(double) );
xd = malloc( INDEX5 * sizeof(double) );
yd = malloc( INDEX5 * sizeof(double) );
if ( !( ad && xd && yd ) )
retval = PAPI_ENOMEM;
} else {
a = malloc( INDEX5 * INDEX5 * sizeof(float) );
x = malloc( INDEX5 * sizeof(float) );
y = malloc( INDEX5 * sizeof(float) );
if ( !( a && x && y ) )
retval = PAPI_ENOMEM;
}
if ( retval == PAPI_OK ) {
headerlines( "Matrix Vector Test", TESTS_QUIET );
/* step through the different array sizes */
for ( n = 0; n < INDEX5; n++ ) {
if ( n < INDEX1 || ( ( n + 1 ) % 50 ) == 0 ) {
/* Initialize the needed arrays at this size */
if ( double_precision ) {
for ( i = 0; i <= n; i++ ) {
yd[i] = 0.0;
xd[i] = ( double ) rand( ) * ( double ) 1.1;
for ( j = 0; j <= n; j++ )
ad[i * n + j] =
( double ) rand( ) * ( double ) 1.1;
}
} else {
for ( i = 0; i <= n; i++ ) {
y[i] = 0.0;
x[i] = ( float ) rand( ) * ( float ) 1.1;
for ( j = 0; j <= n; j++ )
a[i * n + j] =
( float ) rand( ) * ( float ) 1.1;
}
}
/* reset PAPI flops count */
reset_flops( "Matrix Vector Test", EventSet );
/* compute the resultant vector */
if ( double_precision ) {
vector_double( n, ad, xd, yd );
dummy( ( void * ) yd );
} else {
vector_single( n, a, x, y );
dummy( ( void * ) y );
}
resultline( n, 2, EventSet );
}
}
}
if (double_precision) {
free( ad );
free( xd );
free( yd );
} else {
free( a );
free( x );
free( y );
}
}
/* Matrix Multiply test */
if ( matrix && retval != PAPI_ENOMEM ) {
/* Allocate the needed arrays */
if (double_precision) {
ad = malloc( INDEX5 * INDEX5 * sizeof(double) );
bd = malloc( INDEX5 * INDEX5 * sizeof(double) );
cd = malloc( INDEX5 * INDEX5 * sizeof(double) );
if ( !( ad && bd && cd ) )
retval = PAPI_ENOMEM;
} else {
a = malloc( INDEX5 * INDEX5 * sizeof(float) );
b = malloc( INDEX5 * INDEX5 * sizeof(float) );
c = malloc( INDEX5 * INDEX5 * sizeof(float) );
if ( !( a && b && c ) )
retval = PAPI_ENOMEM;
}
if ( retval == PAPI_OK ) {
headerlines( "Matrix Multiply Test", TESTS_QUIET );
/* step through the different array sizes */
for ( n = 0; n < INDEX5; n++ ) {
if ( n < INDEX1 || ( ( n + 1 ) % 50 ) == 0 ) {
/* Initialize the needed arrays at this size */
if ( double_precision ) {
for ( i = 0; i <= n * n + n; i++ ) {
cd[i] = 0.0;
ad[i] = ( double ) rand( ) * ( double ) 1.1;
bd[i] = ( double ) rand( ) * ( double ) 1.1;
}
} else {
for ( i = 0; i <= n * n + n; i++ ) {
c[i] = 0.0;
a[i] = ( float ) rand( ) * ( float ) 1.1;
b[i] = ( float ) rand( ) * ( float ) 1.1;
}
}
/* reset PAPI flops count */
reset_flops( "Matrix Multiply Test", EventSet );
/* compute the resultant matrix */
if ( double_precision ) {
matrix_double( n, cd, ad, bd );
dummy( ( void * ) c );
} else {
matrix_single( n, c, a, b );
dummy( ( void * ) c );
}
resultline( n, 3, EventSet );
}
}
}
if (double_precision) {
free( ad );
free( bd );
free( cd );
} else {
free( a );
free( b );
free( c );
}
}
/* exit with status code */
if ( retval == PAPI_ENOMEM )
test_fail( __FILE__, __LINE__, "malloc", retval );
else
test_pass( __FILE__, NULL, 0 );
exit( 1 );
}
void initSolution(Atom *atom, Molecule *molecule)
{
const char routineName[] = "initSolution";
register int k, i, ij, nspect, mu, n, kr, nact;
char permission[3];
bool_t result, openJfile;
int la, j, niter, Nsr, Nplane, index, status, oflag;
double gijk, wla, twohnu3_c2, hc_k, twoc, fourPI, *J, *J20;
ActiveSet *as;
AtomicLine *line;
AtomicContinuum *continuum;
XDR xdrs;
double cswitch;
int to_obs,lamuk,sign,ncoef,ilow,Nlamu,lamu;
long int idx, lc;
double *lambda,fac,lambda_prv,lambda_gas,lambda_nxt,dl,frac,lag;
FILE *fp;
getCPU(2, TIME_START, NULL);
/* Collisional-radiative switching ? */
if (input.crsw != 0.0)
cswitch = input.crsw_ini;
else
cswitch = 1.0;
/* --- Allocate space for angle-averaged mean intensity -- -------- */
if (!input.limit_memory)
spectrum.J = matrix_double(spectrum.Nspect, atmos.Nspace);
/* --- If we do background polarization we need space for the
anisotropy -- -------------- */
if (input.backgr_pol)
spectrum.J20 = matrix_double(spectrum.Nspect, atmos.Nspace);
/* --- For the PRD angle approximation we need to store J in
the gas frame, -------- */
if (input.PRD_angle_dep == PRD_ANGLE_APPROX && atmos.NPRDactive > 0) {
spectrum.Jgas = matrix_double(spectrum.Nspect, atmos.Nspace);
spectrum.v_los = matrix_double( atmos.Nrays, atmos.Nspace);
/* Calculate line of sight velocity */
for (mu = 0; mu < atmos.Nrays; mu++) {
for (k = 0; k < atmos.Nspace; k++) {
spectrum.v_los[mu][k] = vproject(k, mu); // / vbroad[k];
}
}
/* precompute prd_rho interpolation coefficients if requested */
if (!input.prdh_limit_mem) {
for (nact = 0; nact < atmos.Nactiveatom; nact++) {
atom = atmos.activeatoms[nact];
for (kr = 0; kr < atom->Nline; kr++) {
line = &atom->line[kr];
if (line->PRD) {
Nlamu = 2*atmos.Nrays * line->Nlambda;
line->frac = matrix_double(Nlamu, atmos.Nspace);
line->id0 = matrix_int(Nlamu, atmos.Nspace);
line->id1 = matrix_int(Nlamu, atmos.Nspace);
for (la = 0; la < line->Nlambda; la++) {
for (mu = 0; mu < atmos.Nrays; mu++) {
for (to_obs = 0; to_obs <= 1; to_obs++) {
sign = (to_obs) ? 1.0 : -1.0;
lamu = 2*(atmos.Nrays*la + mu) + to_obs;
for (k = 0; k < atmos.Nspace; k++) {
// wavelength in local rest frame
lag=line->lambda[la] * (1.+spectrum.v_los[mu][k]*sign/CLIGHT);
if (lag <= line->lambda[0]) {
// out of the lambda table, constant extrapolation
line->frac[lamu][k]=0.0;
line->id0[lamu][k]=0;
line->id1[lamu][k]=1;
} else if (lag >= line->lambda[line->Nlambda-1] ) {
// out of the lambda table, constant extrapolation
line->frac[lamu][k]=1.0;
line->id0[lamu][k]=line->Nlambda-2;
line->id1[lamu][k]=line->Nlambda-1;
} else {
// Locate index of line->lambda of point directly to the left of lag
Locate(line->Nlambda,line->lambda,lag,&ilow);
line->frac[lamu][k] = (lag-line->lambda[ilow])/ (line->lambda[ilow+1]-line->lambda[ilow]);
line->id0[lamu][k]=ilow;
line->id1[lamu][k]=ilow+1;
}
}
}
}
}
}
}
}
}
/* precompute Jgas interpolation coefficients if requested */
if (!input.prdh_limit_mem) {
lambda = spectrum.lambda;
/* --- keeps track of where to get indices and interpolation
coefficients in spectrum.iprhh and spectrum.cprdh --- */
spectrum.nc= (int *) malloc( 2*atmos.Nrays*spectrum.Nspect*atmos.Nspace * sizeof(int));
for (la = 0; la < spectrum.Nspect; la++) {
for (mu = 0; mu < atmos.Nrays; mu++) {
for (to_obs = 0; to_obs <= 1; to_obs++) {
sign = (to_obs) ? 1.0 : -1.0;
for (k = 0; k < atmos.Nspace; k++) {
lamuk = la * (atmos.Nrays*2*atmos.Nspace)
+ mu * (2*atmos.Nspace)
+ to_obs * (atmos.Nspace)
+ k ;
ncoef=0;
// previous, current and next wavelength shifted to gas rest frame
fac = (1.+spectrum.v_los[mu][k]*sign/CLIGHT);
lambda_prv = lambda[ MAX(la-1,0) ]*fac;
lambda_gas = lambda[ la ]*fac;
lambda_nxt = lambda[ MIN(la+1,spectrum.Nspect-1) ]*fac;
// do lambda_prv and lambda_gas bracket lambda points?
if (lambda_prv != lambda_gas) {
dl= lambda_gas - lambda_prv;
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] > lambda_prv && lambda[idx] <= lambda_gas) ncoef=ncoef+1;
}
} else {
// edge case, use constant extrapolation for lambda[idx]<lambda gas
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] <= lambda_gas) ncoef=ncoef+1;
}
}
// do lambda_gas and lambda_nxt bracket lambda points?
if (lambda_gas != lambda_nxt) {
dl= lambda_nxt - lambda_gas;
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] > lambda_gas && lambda[idx] < lambda_nxt) ncoef=ncoef+1;
}
} else {
// edge case, use constant extrapolation for lambda[idx]>lambda gas
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] >= lambda_gas) ncoef=ncoef+1;
}
}
/* --- number of point this lambda contributes to is
computed as a difference --- */
if (lamuk == 0) {
spectrum.nc[lamuk] = ncoef;
} else {
spectrum.nc[lamuk]=spectrum.nc[lamuk-1]+ncoef;
}
} // k
} // to_obs
} // mu
} // la
/* --- now we know the number of interpolation coefficients,
it's stored in the last element of spectrum.nc,
so allocate space --- */
idx=spectrum.nc[2*atmos.Nrays*spectrum.Nspect*atmos.Nspace-1];
spectrum.iprdh= (int *) malloc( idx * sizeof(int ));
spectrum.cprdh= (double *) malloc( idx * sizeof(double));
/* --- Run through all lamuk points again, and now store indices
to lambda array and the corresponding interpolation
coefficients --- */
for (la = 0; la < spectrum.Nspect; la++) {
for (mu = 0; mu < atmos.Nrays; mu++) {
for (to_obs = 0; to_obs <= 1; to_obs++) {
sign = (to_obs) ? 1.0 : -1.0;
for (k = 0; k < atmos.Nspace; k++) {
lamuk = la * (atmos.Nrays*2*atmos.Nspace)
+ mu * (2*atmos.Nspace)
+ to_obs * (atmos.Nspace)
+ k ;
// starting index for storage for this lamuk point
lc = (lamuk==0) ? 0 : spectrum.nc[lamuk-1];
// previous, current and next wavelength shifted to gas rest frame
fac = (1.+spectrum.v_los[mu][k]*sign/CLIGHT);
lambda_prv = lambda[ MAX(la-1,0) ]*fac;
lambda_gas = lambda[ la ]*fac;
lambda_nxt = lambda[ MIN(la+1,spectrum.Nspect-1) ]*fac;
// do lambda_prv and lambda_gas bracket lambda points?
if (lambda_prv != lambda_gas) {
dl= lambda_gas - lambda_prv;
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] > lambda_prv && lambda[idx] <= lambda_gas) {
// bracketed point found
spectrum.iprdh[lc]=idx;
spectrum.cprdh[lc]=(lambda[idx]-lambda_prv)/dl;
lc++;
}
}
} else {
// edge case, use constant extrapolation for lambda[idx]<lambda gas
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] <= lambda_gas) {
spectrum.iprdh[lc]=idx;
spectrum.cprdh[lc]=1.0;
lc++;
}
}
}
// do lambda_gas and lambda_nxt bracket lambda points?
if (lambda_gas != lambda_nxt) {
dl= lambda_nxt - lambda_gas;
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] > lambda_gas && lambda[idx] < lambda_nxt) {
// bracketed point found
spectrum.iprdh[lc]=idx;
spectrum.cprdh[lc]=1.0 - (lambda[idx]-lambda_gas)/dl;
lc++;
}
}
} else {
// edge case, use constant extrapolation for lambda[idx]>lambda gas
for (idx = 0; idx < spectrum.Nspect ; idx++) {
if (lambda[idx] >= lambda_gas) {
spectrum.iprdh[lc]=idx;
spectrum.cprdh[lc]=1.0;
lc++;
}
}
}
} // k
} // to_obs
} // mu
} // la
} //input.prdh_limit_mem if switch
} // PRD_ANGLE_APPROX if switch
/* --- Allocate space for the emergent intensity -- -------------- */
switch (topology) {
case ONE_D_PLANE:
spectrum.I = matrix_double(spectrum.Nspect, atmos.Nrays);
if (atmos.Stokes || input.backgr_pol) {
spectrum.Stokes_Q = matrix_double(spectrum.Nspect, atmos.Nrays);
spectrum.Stokes_U = matrix_double(spectrum.Nspect, atmos.Nrays);
spectrum.Stokes_V = matrix_double(spectrum.Nspect, atmos.Nrays);
}
break;
case TWO_D_PLANE:
Nsr = spectrum.Nspect * atmos.Nrays;
spectrum.I = matrix_double(Nsr, atmos.N[0]);
if (atmos.Stokes || input.backgr_pol) {
spectrum.Stokes_Q = matrix_double(Nsr, atmos.N[0]);
spectrum.Stokes_U = matrix_double(Nsr, atmos.N[0]);
spectrum.Stokes_V = matrix_double(Nsr, atmos.N[0]);
}
break;
case THREE_D_PLANE:
spectrum.I = matrix_double(spectrum.Nspect * atmos.Nrays,
atmos.N[0] * atmos.N[1]);
if (atmos.Stokes || input.backgr_pol) {
Nsr = spectrum.Nspect * atmos.Nrays;
Nplane = atmos.N[0] * atmos.N[1];
spectrum.I = matrix_double(Nsr, Nplane);
if (atmos.Stokes || input.backgr_pol) {
spectrum.Stokes_Q = matrix_double(Nsr, Nplane);
spectrum.Stokes_U = matrix_double(Nsr, Nplane);
spectrum.Stokes_V = matrix_double(Nsr, Nplane);
}
}
break;
case SPHERICAL_SYMMETRIC:
spectrum.I = matrix_double(spectrum.Nspect, atmos.Nrays);
if (atmos.Stokes) {
Error(ERROR_LEVEL_2, routineName,
"Cannot do a full Stokes solution in spherical geometry");
}
break;
default:
sprintf(messageStr, "Unknown topology (%d)", topology);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
/* --- Read angle-averaged intensity from previous run if necessary,
and open file for J in case option for limited memory is set */
spectrum.fd_J = -1;
spectrum.fd_J20 = -1;
oflag = 0;
openJfile = FALSE;
if (input.startJ == OLD_J) {
if (spectrum.updateJ) {
strcpy(permission, "r+");
oflag |= O_RDWR;
} else {
strcpy(permission, "r");
oflag |= O_RDONLY;
}
openJfile = TRUE;
} else {
if (input.limit_memory) {
strcpy(permission, "w+");
oflag |= (O_RDWR | O_CREAT);
openJfile = TRUE;
}
}
if (openJfile) {
if ((spectrum.fd_J = open(input.JFile, oflag, PERMISSIONS)) == -1) {
sprintf(messageStr,
"Unable to open input file %s with permission %s",
input.JFile, permission);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
if (input.backgr_pol) {
if ((spectrum.fd_J20 = open(J20_DOT_OUT, oflag,
PERMISSIONS)) == -1) {
sprintf(messageStr,
"Unable to open input file %s with permission %s",
J20_DOT_OUT, permission);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
}
}
if (input.limit_memory) {
if (oflag & O_CREAT) {
J = (double *) malloc(atmos.Nspace * sizeof(double));
/* --- Initialize J file with zeroes -- -------------- */
for (k = 0; k < atmos.Nspace; k++) J[k] = 0.0;
for (nspect = 0; nspect < spectrum.Nspect; nspect++)
writeJlambda(nspect, J);
free(J);
if (input.backgr_pol) {
J20 = (double *) malloc(atmos.Nspace * sizeof(double));
for (k = 0; k < atmos.Nspace; k++) J20[k] = 0.0;
for (nspect = 0; nspect < spectrum.Nspect; nspect++)
writeJ20lambda(nspect, J20);
free(J20);
}
}
} else {
if (input.startJ == OLD_J) {
/* --- Fill matrix J with old values from previous run ----- -- */
for (nspect = 0; nspect < spectrum.Nspect; nspect++)
readJlambda(nspect, spectrum.J[nspect]);
close(spectrum.fd_J);
spectrum.fd_J = -1;
if (input.backgr_pol) {
for (nspect = 0; nspect < spectrum.Nspect; nspect++)
readJ20lambda(nspect, spectrum.J20[nspect]);
close(spectrum.fd_J20);
spectrum.fd_J20 = -1;
}
}
/* --- Look for Jgas and read, otherwise use spectrum.J ----- -- */
if (atmos.NPRDactive > 0 && input.PRD_angle_dep == PRD_ANGLE_APPROX) {
fp=fopen("Jgas.dat","r");
if (fp) {
// file exists
fclose(fp);
readJgas(spectrum.Jgas);
sprintf(messageStr, "Read spectrum.Jgas from file.");
Error(MESSAGE, routineName, messageStr);
} else {
//file does not exist
sprintf(messageStr, "Jgas.dat does not exist,setting spectrum.Jgas spectrum.J.");
Error(WARNING, routineName, messageStr);
for (k = 0; k < atmos.Nspace; k++) {
for (nspect = 0; nspect < spectrum.Nspect; nspect++) {
spectrum.Jgas[nspect][k]=spectrum.J[nspect][k];
}
}
}
}
}
/* --- Need storage for angle-dependent specific intensities for
angle-dependent PRD -- -------------- */
if (atmos.NPRDactive > 0 && input.PRD_angle_dep == PRD_ANGLE_DEP) {
oflag = 0;
if (input.startJ == OLD_J) {
if (spectrum.updateJ) {
strcpy(permission, "r+");
oflag |= O_RDWR;
} else {
strcpy(permission, "r");
oflag |= O_RDONLY;
}
} else {
strcpy(permission, "w+");
oflag |= (O_RDWR | O_CREAT);
}
if ((spectrum.fd_Imu = open(IMU_FILENAME, oflag, PERMISSIONS)) == -1) {
sprintf(messageStr, "Unable to open %s file %s with permission %s",
(spectrum.updateJ) ? "update" : "input",
IMU_FILENAME, permission);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
/* --- Fill the index list that keeps track of the location
of intensity Imu in file spectrum.fd_Imu at wavelength
corresponding to nspect. -- -------------- */
spectrum.PRDindex = (int *) malloc(spectrum.Nspect * sizeof(int));
index = 0;
for (nspect = 0; nspect < spectrum.Nspect; nspect++) {
if (containsPRDline(&spectrum.as[nspect])) {
spectrum.PRDindex[nspect] = index;
index++;
}
}
}
for (nact = 0; nact < atmos.Nactiveatom; nact++) {
atom = atmos.activeatoms[nact];
/* --- Allocate memory for the rate equation matrix -- ---------- */
atom->Gamma = matrix_double(SQ(atom->Nlevel), atmos.Nspace);
/* --- Initialize the mutex lock for the operator Gamma if there
are more than one threads -- -------------- */
if (input.Nthreads > 0) {
if ((status = pthread_mutex_init(&atom->Gamma_lock, NULL))) {
sprintf(messageStr, "Unable to initialize mutex_lock, status = %d",
status);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
}
switch(atom->initial_solution) {
case LTE_POPULATIONS:
for (i = 0; i < atom->Nlevel; i++) {
for (k = 0; k < atmos.Nspace; k++)
atom->n[i][k] = atom->nstar[i][k];
}
break;
case ZERO_RADIATION:
hc_k = (HPLANCK * CLIGHT) / (KBOLTZMANN * NM_TO_M);
twoc = 2.0*CLIGHT / CUBE(NM_TO_M);
fourPI = 4.0 * PI;
initGammaAtom(atom,cswitch);
/* --- Then add radiative contributions of active transitions -- */
for (nspect = 0; nspect < spectrum.Nspect; nspect++) {
as = spectrum.as + nspect;
for (n = 0; n < as->Nactiveatomrt[nact]; n++) {
switch (as->art[nact][n].type) {
case ATOMIC_LINE:
line = as->art[nact][n].ptype.line;
la = nspect - line->Nblue;
i = line->i;
j = line->j;
ij = i*atom->Nlevel + j;
if (la == 0) {
for (k = 0; k < atmos.Nspace; k++)
atom->Gamma[ij][k] += line->Aji;
}
break;
case ATOMIC_CONTINUUM:
continuum = as->art[nact][n].ptype.continuum;
la = nspect - continuum->Nblue;
i = continuum->i;
j = continuum->j;
ij = i*atom->Nlevel + j;
wla = fourPI * getwlambda_cont(continuum, la) /
continuum->lambda[la];
twohnu3_c2 = twoc / CUBE(continuum->lambda[la]);
for (k = 0; k < atmos.Nspace; k++) {
gijk = atom->nstar[i][k]/atom->nstar[j][k] *
exp(-hc_k/(continuum->lambda[la] * atmos.T[k]));
atom->Gamma[ij][k] += gijk * twohnu3_c2 *
continuum->alpha[la]*wla;
}
break;
default:
break;
}
}
}
/* --- Solve statistical equilibrium equations -- ------------ */
statEquil(atom, (input.isum == -1) ? 0 : input.isum);
break;
case OLD_POPULATIONS:
readPopulations(atom);
break;
default:
;
break;
}
}
/* --- Now the molecules that are active -- -------------- */
for (nact = 0; nact < atmos.Nactivemol; nact++) {
molecule = atmos.activemols[nact];
/* --- Calculate the LTE vibration level populations here. They
cannot be calculated yet in readMolecule since chemical
equilibrium has to be established first -- -------------- */
for (i = 0; i < molecule->Nv; i++) {
for (k = 0; k < atmos.Nspace; k++)
molecule->nvstar[i][k] = molecule->n[k] *
molecule->pfv[i][k] / molecule->pf[k];
}
/* --- Allocate memory for the rate equation matrix -- ---------- */
molecule->Gamma = matrix_double(SQ(molecule->Nv), atmos.Nspace);
/* --- Initialize the mutex lock for the operator Gamma if there
are more than one thread -- -------------- */
if (input.Nthreads > 0) {
if ((status = pthread_mutex_init(&molecule->Gamma_lock, NULL))) {
sprintf(messageStr, "Unable to initialize mutex_lock, status = %d",
status);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
}
switch(molecule->initial_solution) {
case LTE_POPULATIONS:
for (i = 0; i < molecule->Nv; i++) {
for (k = 0; k < atmos.Nspace; k++)
molecule->nv[i][k] = molecule->nvstar[i][k];
}
break;
case OLD_POPULATIONS:
readMolPops(molecule);
break;
default:
;
}
/* --- Calculate collisions for molecule (must be done here because
rotation-vibration transitions are dominated by hydrogen and
H2 collisions for which chemical equilibrium needs to be
established first -- -------------- */
if (strstr(molecule->ID, "CO"))
COcollisions(molecule);
else {
sprintf(messageStr, "Collisions for molecule %s not implemented\n",
molecule->ID);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
}
}
flags rlk_opacity(double lambda, int nspect, int mu, bool_t to_obs,
double *chi, double *eta, double *scatt, double *chip)
{
register int k, n, kr;
bool_t contributes, hunt;
int Nwhite, Nblue, Nred, NrecStokes;
double dlamb_wing, *pf, dlamb_char, hc_la, ni_gi, nj_gj, lambda0, kT,
Bijhc_4PI, twohnu3_c2, hc, fourPI, hc_4PI,
*eta_Q, *eta_U, *eta_V, eta_l,
*chi_Q, *chi_U, *chi_V, chi_l, *chip_Q, *chip_U, *chip_V,
phi, phi_Q, phi_U, phi_V, psi_Q, psi_U, psi_V,
epsilon, C, C2_atom, C2_ion, C3, dE, x;
Atom *metal;
AtomicLine *line;
Element *element;
RLK_Line *rlk;
flags backgrflags;
/* --- Calculate the LTE opacity at wavelength lambda due to atomic
transitions stored in atmos.rlk_lines -- -------------- */
backgrflags.hasline = FALSE;
backgrflags.ispolarized = FALSE;
/* --- If wavelength outside our list return without calculation -- */
dlamb_char = lambda * Q_WING * (atmos.vmicro_char / CLIGHT);
if (lambda < atmos.rlk_lines[0].lambda0 - dlamb_char ||
lambda > atmos.rlk_lines[atmos.Nrlk-1].lambda0 + dlamb_char) {
return backgrflags;
}
hc = HPLANCK * CLIGHT;
fourPI = 4.0 * PI;
hc_4PI = hc / fourPI;
if (input.rlkscatter) {
C = 2 * PI * (Q_ELECTRON/EPSILON_0) *
(Q_ELECTRON/M_ELECTRON) / CLIGHT;
C2_atom = 2.15E-6;
C2_ion = 3.96E-6;
}
pf = (double *) malloc(atmos.Nspace * sizeof(double));
/* --- locate wavelength lambda in table of lines -- -------------- */
Nwhite = 0;
rlk_locate(atmos.Nrlk, atmos.rlk_lines, lambda, &Nwhite);
Nblue = Nwhite;
while (atmos.rlk_lines[Nblue].lambda0 + dlamb_char > lambda &&
Nblue > 0) Nblue--;
Nred = Nwhite;
while (atmos.rlk_lines[Nred].lambda0 - dlamb_char < lambda &&
Nred < atmos.Nrlk-1) Nred++;
/* --- Initialize the contribution for this wavelength and angle -- */
if (Nred >= Nblue) {
if (atmos.Stokes) {
NrecStokes = 4;
/* --- Use pointers to sub-arrays for Q, U, and V -- ---------- */
chi_Q = chi + atmos.Nspace;
chi_U = chi + 2*atmos.Nspace;
chi_V = chi + 3*atmos.Nspace;
eta_Q = eta + atmos.Nspace;
eta_U = eta + 2*atmos.Nspace;
eta_V = eta + 3*atmos.Nspace;
if (input.magneto_optical) {
chip_Q = chip;
chip_U = chip + atmos.Nspace;
chip_V = chip + 2*atmos.Nspace;
for (k = 0; k < 3*atmos.Nspace; k++) chip[k] = 0.0;
}
} else
NrecStokes = 1;
for (k = 0; k < NrecStokes * atmos.Nspace; k++) {
chi[k] = 0.0;
eta[k] = 0.0;
}
if (input.rlkscatter) {
for (k = 0; k < atmos.Nspace; k++) scatt[k] = 0.0;
}
}
/* --- Add opacities from lines at this wavelength -- ------------- */
for (n = Nblue; n <= Nred; n++) {
rlk = &atmos.rlk_lines[n];
if (fabs(rlk->lambda0 - lambda) <= dlamb_char) {
element = &atmos.elements[rlk->pt_index - 1];
/* --- Check whether partition function is present for this
stage, and if abundance is set -- -------------- */
if ((rlk->stage < element->Nstage - 1) && element->abundance_set) {
contributes = TRUE;
if ((metal = element->model) != NULL) {
/* --- If an explicit atomic model is present check that we
do not already account for this line in this way - - */
for (kr = 0; kr < metal->Nline; kr++) {
line = metal->line + kr;
dlamb_wing = line->lambda0 * line->qwing *
(atmos.vmicro_char / CLIGHT);
if (fabs(lambda - line->lambda0) <= dlamb_wing &&
metal->stage[line->i] == rlk->stage) {
contributes = FALSE;
break;
}
}
}
} else
contributes = FALSE;
/* --- Get opacity from line -- -------------- */
if (contributes) {
hc_la = (HPLANCK * CLIGHT) / (rlk->lambda0 * NM_TO_M);
Bijhc_4PI = hc_4PI * rlk->Bij * rlk->isotope_frac *
rlk->hyperfine_frac * rlk->gi;
twohnu3_c2 = rlk->Aji / rlk->Bji;
if (input.rlkscatter) {
if (rlk->stage == 0) {
x = 0.68;
C3 = C / (C2_atom * SQ(rlk->lambda0 * NM_TO_M));
} else {
x = 0.0;
C3 = C / (C2_ion * SQ(rlk->lambda0 * NM_TO_M));
}
dE = rlk->Ej - rlk->Ei;
}
/* --- Set flag that line is present at this wavelength -- -- */
backgrflags.hasline = TRUE;
if (rlk->polarizable) {
backgrflags.ispolarized = TRUE;
if (rlk->zm == NULL) rlk->zm = RLKZeeman(rlk);
}
if (element->n == NULL) {
element->n = matrix_double(element->Nstage, atmos.Nspace);
LTEpops_elem(element);
}
Linear(atmos.Npf, atmos.Tpf, element->pf[rlk->stage],
atmos.Nspace, atmos.T, pf, hunt=TRUE);
for (k = 0; k < atmos.Nspace; k++) {
phi = RLKProfile(rlk, k, mu, to_obs, lambda,
&phi_Q, &phi_U, &phi_V,
&psi_Q, &psi_U, &psi_V);
if (phi){
kT = 1.0 / (KBOLTZMANN * atmos.T[k]);
ni_gi = element->n[rlk->stage][k] * exp(-rlk->Ei*kT - pf[k]);
nj_gj = ni_gi * exp(-hc_la * kT);
chi_l = Bijhc_4PI * (ni_gi - nj_gj);
eta_l = Bijhc_4PI * twohnu3_c2 * nj_gj;
if (input.rlkscatter) {
epsilon = 1.0 / (1.0 + C3 * pow(atmos.T[k], 1.5) /
(atmos.ne[k] *
pow(KBOLTZMANN * atmos.T[k] / dE, 1 + x)));
scatt[k] += (1.0 - epsilon) * chi_l * phi;
chi_l *= epsilon;
eta_l *= epsilon;
}
chi[k] += chi_l * phi;
eta[k] += eta_l * phi;
if (rlk->zm != NULL && rlk->Grad) {
chi_Q[k] += chi_l * phi_Q;
chi_U[k] += chi_l * phi_U;
chi_V[k] += chi_l * phi_V;
eta_Q[k] += eta_l * phi_Q;
eta_U[k] += eta_l * phi_U;
eta_V[k] += eta_l * phi_V;
if (input.magneto_optical) {
chip_Q[k] += chi_l * psi_Q;
chip_U[k] += chi_l * psi_U;
chip_V[k] += chi_l * psi_V;
}
}
}
}
}
}
}
free(pf);
return backgrflags;
}
void CollisionRate(struct Atom *atom, FILE *fp_atom)
{
const char routineName[] = "CollisionRate";
register int k, n,m;
char inputLine[MAX_LINE_SIZE], *keyword, *pointer,
labelStr[MAX_LINE_SIZE];
bool_t hunt, exit_on_EOF;
int nitem, i1, i2, i, j, ij, ji, Nlevel = atom->Nlevel, Nitem,
status;
long Nspace = atmos.Nspace, collpos;
double dE, C0, *T, *coeff, *C, Cdown, Cup, gij, *np,xj,fac,fxj;
/* JL additions start */
double **cdi;
int Ncoef,mshell=5;
double acolsh,tcolsh,aradsh,xradsh,adish,bdish,t0sh,t1sh,summrs,tg,cdn,cup;
double ar85t1,ar85t2,ar85a,ar85b,ar85c,ar85d,t4;
double de,zz,betab,cbar,dekt,dekti,wlog,wb;
/* JL additions end */
getCPU(3, TIME_START, NULL);
C0 = ((E_RYDBERG/sqrt(M_ELECTRON)) * PI*SQ(RBOHR)) *
sqrt(8.0/(PI*KBOLTZMANN));
atom->C = matrix_double(SQ(Nlevel), Nspace);
for (ij = 0; ij < SQ(Nlevel); ij++) {
for (k = 0; k < Nspace; k++) {
atom->C[ij][k] = 0.0;
}
}
collpos=ftell(fp_atom);
C = (double *) malloc(Nspace * sizeof(double));
T = coeff = NULL;
while ((status = getLine(fp_atom, COMMENT_CHAR,
inputLine, exit_on_EOF=FALSE)) != EOF) {
keyword = strtok(inputLine, " ");
if (!strcmp(keyword, "TEMP")) {
/* --- Read temperature grid -- -------------- */
Nitem = atoi(strtok(NULL, " "));
T = (double *) realloc(T, Nitem*sizeof(double));
for (n = 0, nitem = 0; n < Nitem; n++) {
if ((pointer = strtok(NULL, " ")) == NULL) break;
nitem += sscanf(pointer, "%lf", T+n);
}
} else if (!strcmp(keyword, "OMEGA") || !strcmp(keyword, "CE") ||
!strcmp(keyword, "CI") || !strcmp(keyword, "CP") ||
!strcmp(keyword, "CH0") || !strcmp(keyword, "CH+")||
!strcmp(keyword, "CH") ) {
/* --- Read level indices and collision coefficients -- ------- */
i1 = atoi(strtok(NULL, " "));
i2 = atoi(strtok(NULL, " "));
coeff = (double *) realloc(coeff, Nitem*sizeof(double));
for (n = 0, nitem = 0; n < Nitem; n++) {
if ((pointer = strtok(NULL, " ")) == NULL) break;
nitem += sscanf(pointer, "%lf", coeff+n);
}
/* --- Transitions i -> j are stored at index ji, transitions
j -> i are stored under ij. -- -------------- */
i = MIN(i1, i2);
j = MAX(i1, i2);
ij = i*Nlevel + j;
ji = j*Nlevel + i;
} else if (!strcmp(keyword, "AR85-CHP") || !strcmp(keyword, "AR85-CHH")) {
i1 = atoi(strtok(NULL, " "));
i2 = atoi(strtok(NULL, " "));
Nitem=6;
coeff = (double *) realloc(coeff, Nitem*sizeof(double));
for (n = 0, nitem = 0; n < Nitem; n++) {
if ((pointer = strtok(NULL, " ")) == NULL) break;
nitem += sscanf(pointer, "%lf", coeff+n);
}
i = MIN(i1, i2);
j = MAX(i1, i2);
ij = i*Nlevel + j;
ji = j*Nlevel + i;
} else if (!strcmp(keyword,"AR85-CEA") || !strcmp(keyword, "BURGESS")) {
i1 = atoi(strtok(NULL, " "));
i2 = atoi(strtok(NULL, " "));
nitem=1;
Nitem=1;
coeff = (double *) realloc(coeff, Nitem*sizeof(double));
coeff[0] = atof(strtok(NULL, " "));
i = MIN(i1, i2);
j = MAX(i1, i2);
ij = i*Nlevel + j;
ji = j*Nlevel + i;
} else if (!strcmp(keyword, "SHULL82")) {
i1 = atoi(strtok(NULL, " "));
i2 = atoi(strtok(NULL, " "));
Nitem=8;
coeff = (double *) realloc(coeff, Nitem*sizeof(double));
for (n = 0, nitem = 0; n < Nitem; n++) {
if ((pointer = strtok(NULL, " ")) == NULL) break;
nitem += sscanf(pointer, "%lf", coeff+n);
}
i = MIN(i1, i2);
j = MAX(i1, i2);
ij = i*Nlevel + j;
ji = j*Nlevel + i;
} else if (!strcmp(keyword, "AR85-CDI")) {
i1 = atoi(strtok(NULL, " "));
i2 = atoi(strtok(NULL, " "));
Ncoef = atoi(strtok(NULL, " "));
if (Ncoef > mshell) {
sprintf(messageStr, "Ncoef: %i greater than mshell %i",Ncoef, mshell );
Error(ERROR_LEVEL_2, routineName, messageStr);
}
Nitem=5;
cdi=matrix_double(Ncoef, Nitem);
for (m = 0; m < Ncoef; m++) {
status=getLine(fp_atom, COMMENT_CHAR,inputLine, exit_on_EOF=FALSE);
cdi[m][0] = atof(strtok(inputLine, " "));
for (n = 1; n < Nitem; n++) {
cdi[m][n] = atof(strtok(NULL, " "));
}
}
i = MIN(i1, i2);
j = MAX(i1, i2);
ij = i*Nlevel + j;
ji = j*Nlevel + i;
nitem=5;
Nitem=5;
keyword="AR85-CDI";
} else if (!strcmp(keyword, "END")) {
break;
} else {
sprintf(messageStr, "Unknown keyword: %s", keyword);
Error(ERROR_LEVEL_1, routineName, messageStr);
}
if (nitem != Nitem) {
sprintf(messageStr, "\n Read %d, not %d items (keyword = %s)\n",
nitem, Nitem, keyword);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
/* --- Spline interpolation in temperature T for all spatial
locations. Linear if only 2 interpolation points given - - */
// if (strcmp(keyword, "TEMP") != 0) {
if (!strcmp(keyword, "OMEGA") || !strcmp(keyword, "CE") ||
!strcmp(keyword, "CI") || !strcmp(keyword, "CP") ||
!strcmp(keyword, "CH0") || !strcmp(keyword, "CH+")||
!strcmp(keyword, "CH") ) {
if (Nitem > 2) {
splineCoef(Nitem, T, coeff);
splineEval(Nspace, atmos.T, C, hunt=TRUE);
} else
Linear(Nitem, T, coeff, Nspace, atmos.T, C, hunt=TRUE);
}
if (!strcmp(keyword, "OMEGA")) {
/* --- Collisional excitation of ions -- -------------- */
for (k = 0; k < Nspace; k++) {
Cdown = C0 * atmos.ne[k] * C[k] /
(atom->g[j] * sqrt(atmos.T[k]));
atom->C[ij][k] += Cdown;
atom->C[ji][k] += Cdown * atom->nstar[j][k]/atom->nstar[i][k];
}
} else if (!strcmp(keyword, "CE")) {
/* --- Collisional excitation of neutrals -- -------------- */
gij = atom->g[i] / atom->g[j];
for (k = 0; k < Nspace; k++) {
Cdown = C[k] * atmos.ne[k] * gij * sqrt(atmos.T[k]);
atom->C[ij][k] += Cdown;
atom->C[ji][k] += Cdown * atom->nstar[j][k]/atom->nstar[i][k];
}
} else if (!strcmp(keyword, "CI")) {
/* --- Collisional ionization -- -------------- */
dE = atom->E[j] - atom->E[i];
for (k = 0; k < Nspace; k++) {
Cup = C[k] * atmos.ne[k] *
exp(-dE/(KBOLTZMANN*atmos.T[k])) * sqrt(atmos.T[k]);
atom->C[ji][k] += Cup;
atom->C[ij][k] += Cup * atom->nstar[i][k]/atom->nstar[j][k];
}
} else if (!strcmp(keyword, "CP")) {
/* --- Collisions with protons -- -------------- */
np = atmos.H->n[atmos.H->Nlevel-1];
for (k = 0; k < Nspace; k++) {
Cdown = np[k] * C[k];
atom->C[ij][k] += Cdown;
atom->C[ji][k] += Cdown * atom->nstar[j][k]/atom->nstar[i][k];
}
} else if (!strcmp(keyword, "CH")) {
/* --- Collisions with neutral hydrogen -- -------------- */
for (k = 0; k < Nspace; k++) {
Cup = atmos.H->n[0][k] * C[k];
atom->C[ji][k] += Cup;
atom->C[ij][k] += Cup * atom->nstar[i][k]/atom->nstar[j][k];
}
} else if (!strcmp(keyword, "CH0")) {
/* --- Charge exchange with neutral hydrogen -- -------------- */
for (k = 0; k < Nspace; k++)
atom->C[ij][k] += atmos.H->n[0][k] * C[k];
} else if (!strcmp(keyword, "CH+")) {
/* --- Charge exchange with protons -- -------------- */
np = atmos.H->n[atmos.H->Nlevel-1];
for (k = 0; k < Nspace; k++)
atom->C[ji][k] += np[k] * C[k];
} else if (!strcmp(keyword, "SHULL82")) {
/* printf("shull82\n");*/
acolsh=coeff[0];
tcolsh=coeff[1];
aradsh=coeff[2];
xradsh=coeff[3];
adish =coeff[4];
bdish =coeff[5];
t0sh =coeff[6];
t1sh =coeff[7];
for (k = 0; k < Nspace; k++) {
summrs=1.0;
summrs=summers(i,j,atmos.ne[k],atom);
tg=atmos.T[k];
cdn= aradsh*pow(tg/1.e4,-xradsh)
+ summrs * adish /tg/sqrt(tg) * exp(-t0sh/tg) *
(1.0+bdish * (exp(- t1sh/tg)));
cup=acolsh * sqrt(tg) * exp( -tcolsh / tg) / (1.0 + 0.1 * tg / tcolsh);
/* --- Convert coefficient from cm^3 s^-1 to m^3 s^-1 -- ---- */
cdn *= atmos.ne[k] * CUBE(CM_TO_M);
cup *= atmos.ne[k] * CUBE(CM_TO_M);
// cdn=cdn*atmos.ne[k];
//cup=cup*atmos.ne[k];
/* 3-body recombination (high density limit) */
cdn = cdn + cup * atom->nstar[i][k] / atom->nstar[j][k];
atom->C[ij][k] += cdn;
atom->C[ji][k] += cup;
}
} else if (!strcmp(keyword, "AR85-CDI")) {
/* printf("ar85-cdi\n");*/
/* Direct collionisional ionization */
for (k = 0; k < Nspace; k++) {
tg=atmos.T[k];
cup=0.0;
for (m = 0; m < Ncoef; m++) {
xj=cdi[m][0] * EV/KBOLTZMANN/tg;
fac=exp(-xj)*sqrt(xj);
fxj= cdi[m][1]+cdi[m][2]*(1.0+xj)
+(cdi[m][3]-xj*(cdi[m][1]+cdi[m][2]
*(2.0+xj)))*fone(xj)+
cdi[m][4]*xj*ftwo(xj);
fxj=fxj*fac;
fac = 6.69e-7 / pow(cdi[m][0],1.5);
cup = cup + fac*fxj * pow(CM_TO_M,3);
}
if (cup<0) {
printf("warning cup= %e and T= %f\n",cup,tg);
cup=0;
}
cup=cup*atmos.ne[k];
cdn=cup*atom->nstar[i][k]/atom->nstar[j][k];
atom->C[ij][k] += cdn;
atom->C[ji][k] += cup;
}
} else if (!strcmp(keyword,"AR85-CEA") ) {
/* Autoionization */
for (k = 0; k < Nspace; k++) {
ar85cea(i,j,k,&fac, atom);
cup=coeff[0]*fac*atmos.ne[k];
atom->C[ji][k] += cup;
}
} else if (!strcmp(keyword, "AR85-CHP")) {
/* charge transfer with ionized hydrogen */
ar85t1=coeff[0];
ar85t2=coeff[1];
ar85a=coeff[2];
ar85b=coeff[3];
ar85c=coeff[4];
ar85d=coeff[5];
for (k = 0; k < Nspace; k++) {
if (atmos.T[k]>=ar85t1 && atmos.T[k]<=ar85t2) {
t4=atmos.T[k]/1.e4;
cup = ar85a * 1e-9 * pow(t4,ar85b) * exp(-ar85c*t4)
* exp(-ar85d*EV/KBOLTZMANN/atmos.T[k])*atmos.H->n[5][k]
* pow(CM_TO_M,3);
atom->C[ji][k] += cup;
}
}
} else if (!strcmp(keyword, "AR85-CHH")) {
/* charge transfer with neutral hydrogen */
ar85t1=coeff[0];
ar85t2=coeff[1];
ar85a=coeff[2];
ar85b=coeff[3];
ar85c=coeff[4];
ar85d=coeff[5];
for (k = 0; k < Nspace; k++) {
if (atmos.T[k]>=ar85t1 && atmos.T[k]<=ar85t2) {
t4=atmos.T[k]/1.e4;
cdn = ar85a * 1e-9 * pow(t4,ar85b) * (1+ar85c*exp(ar85d*t4))
* atmos.H->n[0][k] * pow(CM_TO_M,3);
atom->C[ij][k] += cdn;
}
}
} else if (!strcmp(keyword, "BURGESS")) {
/* Electron impact ionzation following Burgess & Chidichimo,
1982, MNRAS,203,1269-1280 */
de= (atom->E[j]-atom->E[i]) / EV;
zz=atom->stage[i];
betab = 0.25 * ( sqrt( (100.0*zz +91.0) / (4.0*zz+3.0) ) -5.0 );
cbar=2.3;
for (k = 0; k < Nspace; k++) {
dekt=de*EV/KBOLTZMANN/atmos.T[k];
dekt=min(500,dekt);
dekti=1.0/dekt;
wlog=log(1.0 + dekti);
wb= pow(wlog,betab/(1.0+dekti));
cup = 2.1715e-8 * cbar * pow(13.6/de ,1.5) * sqrt(dekt) * E1(dekt) * wb *
atmos.ne[k] * pow(CM_TO_M,3);
cup=cup*coeff[0]; //add fudge factor
cdn = cup*atom->nstar[i][k]/atom->nstar[j][k];
atom->C[ji][k] += cup;
atom->C[ij][k] += cdn;
}
}
}
if (status == EOF) {
sprintf(messageStr, "Reached end of datafile before all data was read");
Error(ERROR_LEVEL_1, routineName, messageStr);
}
/* --- Clean up -- -------------- */
free(C);
free(T);
free(coeff);
fsetpos(fp_atom,&collpos);
sprintf(labelStr, "Collision Rate %2s", atom->ID);
getCPU(3, TIME_POLL, labelStr);
}
void getBoundary(Geometry *geometry)
{
const char routineName[] = "getBoundary";
register int la;
bool_t result = TRUE;
FILE *fp_Itop;
XDR xdrs;
switch (geometry->vboundary[TOP]) {
case ZERO: break;
case THERMALIZED: break;
case IRRADIATED:
sprintf(messageStr, "\n -- reading irradiance input file: %s\n\n",
input.Itop);
Error(MESSAGE, NULL, messageStr);
geometry->Itop = matrix_double(spectrum.Nspect, geometry->Nrays);
/* --- Open input file for irradiation at TOP -- -------------- */
if ((fp_Itop = fopen(input.Itop, "r")) == NULL) {
sprintf(messageStr, "Unable to open inputfile %s", input.Itop);
Error(ERROR_LEVEL_2, routineName, messageStr);
}
xdrstdio_create(&xdrs, fp_Itop, XDR_DECODE);
result &= xdr_vector(&xdrs, (char *) geometry->Itop[0],
spectrum.Nspect * geometry->Nrays,
sizeof(double), (xdrproc_t) xdr_double);
if (!result) {
sprintf(messageStr,
"Unable to read irradiation data at TOP of atmosphere");
Error(ERROR_LEVEL_2, routineName, messageStr);
}
xdr_destroy(&xdrs);
fclose(fp_Itop);
break;
case REFLECTIVE:
break;
default:
Error(ERROR_LEVEL_2, routineName,
"Invalid boundary condition at the TOP of atmosphere");
}
switch (geometry->vboundary[BOTTOM]) {
case ZERO: break;
case THERMALIZED: break;
case IRRADIATED:
geometry->Ibottom = matrix_double(spectrum.Nspect, geometry->Nrays);
/* --- Infalling intensities at BOTTOM should be read here -- --- */
Error(ERROR_LEVEL_1, routineName,
"Boundary condition IRRADIATED at BOTTOM not yet implemented");
break;
case REFLECTIVE:
break;
default:
Error(ERROR_LEVEL_2, routineName,
"Invalid boundary condition at the BOTTOM of atmosphere");
}
}