int wcssptr_(struct wcsprm *wcs, int *i, char ctype[9])
{
int status = wcssptr(wcs, i, ctype);
wcsutil_blank_fill(9, ctype);
return status;
}
int wcserr_get_(const int *err, const int *what, void *value)
{
char *cvalp;
int *ivalp;
const struct wcserr *errp;
/* Cast pointers. */
errp = (const struct wcserr *)err;
cvalp = (char *)value;
ivalp = (int *)value;
switch (*what) {
case WCSERR_STATUS:
*ivalp = errp->status;
break;
case WCSERR_LINE_NO:
*ivalp = errp->line_no;
break;
case WCSERR_FUNCTION:
strncpy(cvalp, errp->function, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCSERR_FILE:
strncpy(cvalp, errp->file, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCSERR_MSG:
strncpy(cvalp, errp->msg, WCSERR_MSG_LENGTH);
wcsutil_blank_fill(WCSERR_MSG_LENGTH, cvalp);
break;
default:
return 1;
}
return 0;
}
int spcset(struct spcprm *spc)
{
static const char *function = "spcset";
char ctype[9], ptype, xtype;
int restreq, status;
double alpha, beta_r, crvalX, dn_r, dXdS, epsilon, G, m, lambda_r, n_r,
t, restfrq, restwav, theta;
struct wcserr **err;
if (spc == 0x0) return SPCERR_NULL_POINTER;
err = &(spc->err);
if (undefined(spc->crval)) {
return wcserr_set(WCSERR_SET(SPCERR_BAD_SPEC_PARAMS),
"Spectral crval is undefined");
}
memset((spc->type)+4, 0, 4);
spc->code[3] = '\0';
wcsutil_blank_fill(4, spc->type);
wcsutil_blank_fill(3, spc->code);
spc->w[0] = 0.0;
/* Analyse the spectral axis type. */
memset(ctype, 0, 9);
strncpy(ctype, spc->type, 4);
if (*(spc->code) != ' ') {
sprintf(ctype+4, "-%s", spc->code);
}
restfrq = spc->restfrq;
restwav = spc->restwav;
if ((status = spcspxe(ctype, spc->crval, restfrq, restwav, &ptype, &xtype,
&restreq, &crvalX, &dXdS, &(spc->err)))) {
return status;
}
/* Satisfy rest frequency/wavelength requirements. */
if (restreq) {
if (restreq == 3 && restfrq == 0.0 && restwav == 0.0) {
/* VRAD-V2F, VOPT-V2W, and ZOPT-V2W require the rest frequency or */
/* wavelength for the S-P and P-X transformations but not for S-X */
/* so supply a phoney value. */
restwav = 1.0;
}
if (restfrq == 0.0) {
restfrq = C/restwav;
} else {
restwav = C/restfrq;
}
if (ptype == 'F') {
spc->w[0] = restfrq;
} else if (ptype != 'V') {
spc->w[0] = restwav;
} else {
if (xtype == 'F') {
spc->w[0] = restfrq;
} else {
spc->w[0] = restwav;
}
}
}
spc->w[1] = crvalX;
spc->w[2] = dXdS;
/* Set pointers-to-functions for the linear part of the transformation. */
if (ptype == 'F') {
if (strcmp(spc->type, "FREQ") == 0) {
/* Frequency. */
spc->flag = FREQ;
spc->spxP2S = 0x0;
spc->spxS2P = 0x0;
} else if (strcmp(spc->type, "AFRQ") == 0) {
/* Angular frequency. */
spc->flag = AFRQ;
spc->spxP2S = freqafrq;
spc->spxS2P = afrqfreq;
} else if (strcmp(spc->type, "ENER") == 0) {
/* Photon energy. */
spc->flag = ENER;
spc->spxP2S = freqener;
spc->spxS2P = enerfreq;
} else if (strcmp(spc->type, "WAVN") == 0) {
/* Wave number. */
spc->flag = WAVN;
spc->spxP2S = freqwavn;
spc->spxS2P = wavnfreq;
} else if (strcmp(spc->type, "VRAD") == 0) {
/* Radio velocity. */
spc->flag = VRAD;
spc->spxP2S = freqvrad;
spc->spxS2P = vradfreq;
}
} else if (ptype == 'W') {
if (strcmp(spc->type, "WAVE") == 0) {
/* Vacuum wavelengths. */
spc->flag = WAVE;
spc->spxP2S = 0x0;
spc->spxS2P = 0x0;
} else if (strcmp(spc->type, "VOPT") == 0) {
/* Optical velocity. */
spc->flag = VOPT;
spc->spxP2S = wavevopt;
spc->spxS2P = voptwave;
} else if (strcmp(spc->type, "ZOPT") == 0) {
/* Redshift. */
spc->flag = ZOPT;
spc->spxP2S = wavezopt;
spc->spxS2P = zoptwave;
}
} else if (ptype == 'A') {
if (strcmp(spc->type, "AWAV") == 0) {
/* Air wavelengths. */
spc->flag = AWAV;
spc->spxP2S = 0x0;
spc->spxS2P = 0x0;
}
} else if (ptype == 'V') {
if (strcmp(spc->type, "VELO") == 0) {
/* Relativistic velocity. */
spc->flag = VELO;
spc->spxP2S = 0x0;
spc->spxS2P = 0x0;
} else if (strcmp(spc->type, "BETA") == 0) {
/* Velocity ratio (v/c). */
spc->flag = BETA;
spc->spxP2S = velobeta;
spc->spxS2P = betavelo;
}
}
/* Set pointers-to-functions for the non-linear part of the spectral */
/* transformation. */
spc->isGrism = 0;
if (xtype == 'F') {
/* Axis is linear in frequency. */
if (ptype == 'F') {
spc->spxX2P = 0x0;
spc->spxP2X = 0x0;
} else if (ptype == 'W') {
spc->spxX2P = freqwave;
spc->spxP2X = wavefreq;
} else if (ptype == 'A') {
spc->spxX2P = freqawav;
spc->spxP2X = awavfreq;
} else if (ptype == 'V') {
spc->spxX2P = freqvelo;
spc->spxP2X = velofreq;
}
spc->flag += F2S;
} else if (xtype == 'W' || xtype == 'w') {
/* Axis is linear in vacuum wavelengths. */
if (ptype == 'F') {
spc->spxX2P = wavefreq;
spc->spxP2X = freqwave;
} else if (ptype == 'W') {
spc->spxX2P = 0x0;
spc->spxP2X = 0x0;
} else if (ptype == 'A') {
spc->spxX2P = waveawav;
spc->spxP2X = awavwave;
} else if (ptype == 'V') {
spc->spxX2P = wavevelo;
spc->spxP2X = velowave;
}
if (xtype == 'W') {
spc->flag += W2S;
} else {
/* Grism in vacuum. */
spc->isGrism = 1;
spc->flag += GRI;
}
} else if (xtype == 'A' || xtype == 'a') {
/* Axis is linear in air wavelengths. */
if (ptype == 'F') {
spc->spxX2P = awavfreq;
spc->spxP2X = freqawav;
} else if (ptype == 'W') {
spc->spxX2P = awavwave;
spc->spxP2X = waveawav;
} else if (ptype == 'A') {
spc->spxX2P = 0x0;
spc->spxP2X = 0x0;
} else if (ptype == 'V') {
spc->spxX2P = awavvelo;
spc->spxP2X = veloawav;
}
if (xtype == 'A') {
spc->flag += A2S;
} else {
/* Grism in air. */
spc->isGrism = 2;
spc->flag += GRA;
}
} else if (xtype == 'V') {
/* Axis is linear in relativistic velocity. */
if (ptype == 'F') {
spc->spxX2P = velofreq;
spc->spxP2X = freqvelo;
} else if (ptype == 'W') {
spc->spxX2P = velowave;
spc->spxP2X = wavevelo;
} else if (ptype == 'A') {
spc->spxX2P = veloawav;
spc->spxP2X = awavvelo;
} else if (ptype == 'V') {
spc->spxX2P = 0x0;
spc->spxP2X = 0x0;
}
spc->flag += V2S;
}
/* Check for grism axes. */
if (spc->isGrism) {
/* Axis is linear in "grism parameter"; work in wavelength. */
lambda_r = crvalX;
/* Set defaults. */
if (undefined(spc->pv[0])) spc->pv[0] = 0.0;
if (undefined(spc->pv[1])) spc->pv[1] = 0.0;
if (undefined(spc->pv[2])) spc->pv[2] = 0.0;
if (undefined(spc->pv[3])) spc->pv[3] = 1.0;
if (undefined(spc->pv[4])) spc->pv[4] = 0.0;
if (undefined(spc->pv[5])) spc->pv[5] = 0.0;
if (undefined(spc->pv[6])) spc->pv[6] = 0.0;
/* Compute intermediaries. */
G = spc->pv[0];
m = spc->pv[1];
alpha = spc->pv[2];
n_r = spc->pv[3];
dn_r = spc->pv[4];
epsilon = spc->pv[5];
theta = spc->pv[6];
t = G*m/cosd(epsilon);
beta_r = asind(t*lambda_r - n_r*sind(alpha));
t -= dn_r*sind(alpha);
spc->w[1] = -tand(theta);
spc->w[2] *= t / (cosd(beta_r)*cosd(theta)*cosd(theta));
spc->w[3] = beta_r + theta;
spc->w[4] = (n_r - dn_r*lambda_r)*sind(alpha);
spc->w[5] = 1.0 / t;
}
return 0;
}
int wcsget_(const int *wcs, const int *what, void *value)
{
int i, j, k, naxis;
char *cvalp;
int *ivalp;
double *dvalp;
const int *iwcsp;
const double *dwcsp;
const struct wcsprm *wcsp;
/* Cast pointers. */
wcsp = (const struct wcsprm *)wcs;
cvalp = (char *)value;
ivalp = (int *)value;
dvalp = (double *)value;
naxis = wcsp->naxis;
switch (*what) {
case WCS_FLAG:
*ivalp = wcsp->flag;
break;
case WCS_NAXIS:
*ivalp = naxis;
break;
case WCS_CRPIX:
for (i = 0; i < naxis; i++) {
*(dvalp++) = wcsp->crpix[i];
}
break;
case WCS_PC:
/* C row-major to FORTRAN column-major. */
for (j = 0; j < naxis; j++) {
dwcsp = wcsp->pc + j;
for (i = 0; i < naxis; i++) {
*(dvalp++) = *dwcsp;
dwcsp += naxis;
}
}
break;
case WCS_CDELT:
for (i = 0; i < naxis; i++) {
*(dvalp++) = wcsp->cdelt[i];
}
break;
case WCS_CRVAL:
for (i = 0; i < naxis; i++) {
*(dvalp++) = wcsp->crval[i];
}
break;
case WCS_CUNIT:
for (i = 0; i < naxis; i++) {
strncpy(cvalp, wcsp->cunit[i], 72);
wcsutil_blank_fill(72, cvalp);
cvalp += 72;
}
break;
case WCS_CTYPE:
for (i = 0; i < naxis; i++) {
strncpy(cvalp, wcsp->ctype[i], 72);
wcsutil_blank_fill(72, cvalp);
cvalp += 72;
}
break;
case WCS_LONPOLE:
*dvalp = wcsp->lonpole;
break;
case WCS_LATPOLE:
*dvalp = wcsp->latpole;
break;
case WCS_RESTFRQ:
*dvalp = wcsp->restfrq;
break;
case WCS_RESTWAV:
*dvalp = wcsp->restwav;
break;
case WCS_NPV:
*ivalp = wcsp->npv;
break;
case WCS_NPVMAX:
*ivalp = wcsp->npvmax;
break;
case WCS_PV:
for (k = 0; k < wcsp->npv; k++) {
*(dvalp++) = (wcsp->pv + k)->i;
*(dvalp++) = (wcsp->pv + k)->m;
*(dvalp++) = (wcsp->pv + k)->value;
}
break;
case WCS_NPS:
*ivalp = wcsp->nps;
break;
case WCS_NPSMAX:
*ivalp = wcsp->npsmax;
break;
case WCS_PS:
for (k = 0; k < wcsp->nps; k++) {
*(dvalp++) = (wcsp->ps + k)->i;
*(dvalp++) = (wcsp->ps + k)->m;
cvalp += 2*sizeof(double);
strncpy(cvalp, (wcsp->ps + k)->value, 72);
wcsutil_blank_fill(72, cvalp);
cvalp += 72;
}
break;
case WCS_CD:
/* C row-major to FORTRAN column-major. */
for (j = 0; j < naxis; j++) {
dwcsp = wcsp->cd + j;
for (i = 0; i < naxis; i++) {
*(dvalp++) = *dwcsp;
dwcsp += naxis;
}
}
break;
case WCS_CROTA:
for (i = 0; i < naxis; i++) {
*(dvalp++) = wcsp->crota[i];
}
break;
case WCS_ALTLIN:
*ivalp = wcsp->altlin;
break;
case WCS_VELREF:
*ivalp = wcsp->velref;
break;
case WCS_ALT:
strncpy(cvalp, wcsp->alt, 4);
wcsutil_blank_fill(4, cvalp);
break;
case WCS_COLNUM:
*ivalp = wcsp->colnum;
break;
case WCS_COLAX:
for (i = 0; i < naxis; i++) {
*(ivalp++) = wcsp->colax[i];
}
break;
case WCS_CNAME:
for (i = 0; i < naxis; i++) {
strncpy(cvalp, wcsp->cname[i], 72);
wcsutil_blank_fill(72, cvalp);
cvalp += 72;
}
break;
case WCS_CRDER:
for (i = 0; i < naxis; i++) {
*(dvalp++) = wcsp->crder[i];
}
break;
case WCS_CSYER:
for (i = 0; i < naxis; i++) {
*(dvalp++) = wcsp->csyer[i];
}
break;
case WCS_DATEAVG:
strncpy(cvalp, wcsp->dateavg, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCS_DATEOBS:
strncpy(cvalp, wcsp->dateobs, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCS_EQUINOX:
*dvalp = wcsp->equinox;
break;
case WCS_MJDAVG:
*dvalp = wcsp->mjdavg;
break;
case WCS_MJDOBS:
*dvalp = wcsp->mjdobs;
break;
case WCS_OBSGEO:
for (i = 0; i < 3; i++) {
*(dvalp++) = wcsp->obsgeo[i];
}
break;
case WCS_RADESYS:
strncpy(cvalp, wcsp->radesys, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCS_SPECSYS:
strncpy(cvalp, wcsp->specsys, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCS_SSYSOBS:
strncpy(cvalp, wcsp->ssysobs, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCS_VELOSYS:
*dvalp = wcsp->velosys;
break;
case WCS_ZSOURCE:
*dvalp = wcsp->zsource;
break;
case WCS_SSYSSRC:
strncpy(cvalp, wcsp->ssyssrc, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCS_VELANGL:
*dvalp = wcsp->velangl;
break;
case WCS_WCSNAME:
strncpy(cvalp, wcsp->wcsname, 72);
wcsutil_blank_fill(72, cvalp);
break;
case WCS_NTAB:
*ivalp = wcsp->ntab;
break;
case WCS_NWTB:
*ivalp = wcsp->nwtb;
break;
case WCS_TAB:
*(void **)value = wcsp->tab;
break;
case WCS_WTB:
*(void **)value = wcsp->wtb;
break;
case WCS_LNGTYP:
strncpy(cvalp, wcsp->lngtyp, 4);
wcsutil_blank_fill(4, cvalp);
break;
case WCS_LATTYP:
strncpy(cvalp, wcsp->lattyp, 4);
wcsutil_blank_fill(4, cvalp);
break;
case WCS_LNG:
*ivalp = wcsp->lng + 1;
break;
case WCS_LAT:
*ivalp = wcsp->lat + 1;
break;
case WCS_SPEC:
*ivalp = wcsp->spec + 1;
break;
case WCS_CUBEFACE:
*ivalp = wcsp->cubeface;
break;
case WCS_TYPES:
for (i = 0; i < naxis; i++) {
*(ivalp++) = wcsp->types[i];
}
break;
case WCS_LIN:
/* Copy the contents of the linprm struct. */
iwcsp = (int *)(&(wcsp->lin));
for (k = 0; k < LINLEN; k++) {
*(ivalp++) = *(iwcsp++);
}
break;
case WCS_CEL:
/* Copy the contents of the celprm struct. */
iwcsp = (int *)(&(wcsp->cel));
for (k = 0; k < CELLEN; k++) {
*(ivalp++) = *(iwcsp++);
}
break;
case WCS_SPC:
/* Copy the contents of the spcprm struct. */
iwcsp = (int *)(&(wcsp->spc));
for (k = 0; k < SPCLEN; k++) {
*(ivalp++) = *(iwcsp++);
}
break;
case WCS_ERR:
/* Copy the contents of the wcserr struct. */
if (wcsp->err) {
iwcsp = (int *)(wcsp->err);
for (k = 0; k < ERRLEN; k++) {
*(ivalp++) = *(iwcsp++);
}
} else {
for (k = 0; k < ERRLEN; k++) {
*(ivalp++) = 0;
}
}
break;
default:
return 1;
}
return 0;
}
void wcslib_version_(char *wcsver, int nchr)
{
strncpy(wcsver, wcslib_version(0x0), nchr);
wcsutil_blank_fill(nchr, wcsver);
}
