1 /*============================================================================
2 WCSLIB 7.7 - an implementation of the FITS WCS standard.
3 Copyright (C) 1995-2021, Mark Calabretta
4
5 This file is part of WCSLIB.
6
7 WCSLIB is free software: you can redistribute it and/or modify it under the
8 terms of the GNU Lesser General Public License as published by the Free
9 Software Foundation, either version 3 of the License, or (at your option)
10 any later version.
11
12 WCSLIB is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14 FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for
15 more details.
16
17 You should have received a copy of the GNU Lesser General Public License
18 along with WCSLIB. If not, see http://www.gnu.org/licenses.
19
20 Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
21 http://www.atnf.csiro.au/people/Mark.Calabretta
22 $Id: prj_f.c,v 7.7 2021/07/12 06:36:49 mcalabre Exp $
23 *===========================================================================*/
24
25 #include <stdio.h>
26 #include <string.h>
27
28 #include <wcserr.h>
29 #include <wcsutil.h>
30 #include <prj.h>
31
32 // Fortran name mangling (see below for the remainder).
33 #include <wcsconfig_f77.h>
34 #define prjput_ F77_FUNC(prjput, PRJPUT)
35 #define prjptc_ F77_FUNC(prjptc, PRJPTC)
36 #define prjptd_ F77_FUNC(prjptd, PRJPTD)
37 #define prjpti_ F77_FUNC(prjpti, PRJPTI)
38 #define prjget_ F77_FUNC(prjget, PRJGET)
39 #define prjgtc_ F77_FUNC(prjgtc, PRJGTC)
40 #define prjgtd_ F77_FUNC(prjgtd, PRJGTD)
41 #define prjgti_ F77_FUNC(prjgti, PRJGTI)
42
43 #define prjini_ F77_FUNC(prjini, PRJINI)
44 #define prjfree_ F77_FUNC(prjfree, PRJFREE)
45 #define prjsize_ F77_FUNC(prjsize, PRJSIZE)
46 #define prjprt_ F77_FUNC(prjprt, PRJPRT)
47 #define prjperr_ F77_FUNC(prjperr, PRJPERR)
48 #define prjbchk_ F77_FUNC(prjbchk, PRJBCHK)
49
50 // Must match the values set in prj.inc.
51 #define PRJ_FLAG 100
52 #define PRJ_CODE 101
53 #define PRJ_R0 102
54 #define PRJ_PV 103
55 #define PRJ_PHI0 104
56 #define PRJ_THETA0 105
57 #define PRJ_BOUNDS 106
58
59 #define PRJ_NAME 200
60 #define PRJ_CATEGORY 201
61 #define PRJ_PVRANGE 202
62 #define PRJ_SIMPLEZEN 203
63 #define PRJ_EQUIAREAL 204
64 #define PRJ_CONFORMAL 205
65 #define PRJ_GLOBAL 206
66 #define PRJ_DIVERGENT 207
67 #define PRJ_X0 208
68 #define PRJ_Y0 209
69 #define PRJ_ERR 210
70 #define PRJ_W 211
71 #define PRJ_N 212
72
73 //----------------------------------------------------------------------------
74
prjput_(int * prj,const int * what,const void * value,const int * m)75 int prjput_(int *prj, const int *what, const void *value, const int *m)
76
77 {
78 const char *cvalp;
79 const int *ivalp;
80 const double *dvalp;
81 struct prjprm *prjp;
82
83 // Cast pointers.
84 prjp = (struct prjprm *)prj;
85 cvalp = (const char *)value;
86 ivalp = (const int *)value;
87 dvalp = (const double *)value;
88
89 switch (*what) {
90 case PRJ_FLAG:
91 prjp->flag = *ivalp;
92 break;
93 case PRJ_CODE:
94 // Only three characters need be given.
95 wcsutil_strcvt(3, ' ', 1, cvalp, prjp->code);
96 wcsutil_null_fill(4, prjp->code);
97 prjp->flag = 0;
98 break;
99 case PRJ_R0:
100 prjp->r0 = *dvalp;
101 prjp->flag = 0;
102 break;
103 case PRJ_PV:
104 prjp->pv[*m] = *dvalp;
105 prjp->flag = 0;
106 break;
107 case PRJ_PHI0:
108 prjp->phi0 = *dvalp;
109 prjp->flag = 0;
110 break;
111 case PRJ_THETA0:
112 prjp->theta0 = *dvalp;
113 prjp->flag = 0;
114 break;
115 case PRJ_BOUNDS:
116 prjp->bounds = *ivalp;
117 break;
118 default:
119 return 1;
120 }
121
122 return 0;
123 }
124
prjptc_(int * prj,const int * what,const char * value,const int * m)125 int prjptc_(int *prj, const int *what, const char *value, const int *m)
126 {
127 return prjput_(prj, what, value, m);
128 }
129
prjptd_(int * prj,const int * what,const double * value,const int * m)130 int prjptd_(int *prj, const int *what, const double *value, const int *m)
131 {
132 return prjput_(prj, what, value, m);
133 }
134
prjpti_(int * prj,const int * what,const int * value,const int * m)135 int prjpti_(int *prj, const int *what, const int *value, const int *m)
136 {
137 return prjput_(prj, what, value, m);
138 }
139
140 //----------------------------------------------------------------------------
141
prjget_(const int * prj,const int * what,void * value)142 int prjget_(const int *prj, const int *what, void *value)
143
144 {
145 unsigned int l;
146 int m;
147 char *cvalp;
148 int *ivalp;
149 double *dvalp;
150 const int *iprjp;
151 const struct prjprm *prjp;
152
153 // Cast pointers.
154 prjp = (const struct prjprm *)prj;
155 cvalp = (char *)value;
156 ivalp = (int *)value;
157 dvalp = (double *)value;
158
159 switch (*what) {
160 case PRJ_FLAG:
161 *ivalp = prjp->flag;
162 break;
163 case PRJ_CODE:
164 wcsutil_strcvt(4, ' ', 0, prjp->code, cvalp);
165 break;
166 case PRJ_R0:
167 *dvalp = prjp->r0;
168 break;
169 case PRJ_PV:
170 for (m = 0; m < PVN; m++) {
171 *(dvalp++) = prjp->pv[m];
172 }
173 break;
174 case PRJ_PHI0:
175 *dvalp = prjp->phi0;
176 break;
177 case PRJ_THETA0:
178 *dvalp = prjp->theta0;
179 break;
180 case PRJ_BOUNDS:
181 *ivalp = prjp->bounds;
182 break;
183 case PRJ_NAME:
184 wcsutil_strcvt(40, ' ', 0, prjp->name, cvalp);
185 break;
186 case PRJ_CATEGORY:
187 *ivalp = prjp->category;
188 break;
189 case PRJ_PVRANGE:
190 *ivalp = prjp->pvrange;
191 break;
192 case PRJ_SIMPLEZEN:
193 *ivalp = prjp->simplezen;
194 break;
195 case PRJ_EQUIAREAL:
196 *ivalp = prjp->equiareal;
197 break;
198 case PRJ_CONFORMAL:
199 *ivalp = prjp->conformal;
200 break;
201 case PRJ_GLOBAL:
202 *ivalp = prjp->global;
203 break;
204 case PRJ_DIVERGENT:
205 *ivalp = prjp->divergent;
206 break;
207 case PRJ_X0:
208 *dvalp = prjp->x0;
209 break;
210 case PRJ_Y0:
211 *dvalp = prjp->y0;
212 break;
213 case PRJ_ERR:
214 // Copy the contents of the wcserr struct.
215 if (prjp->err) {
216 iprjp = (int *)(prjp->err);
217 for (l = 0; l < ERRLEN; l++) {
218 *(ivalp++) = *(iprjp++);
219 }
220 } else {
221 for (l = 0; l < ERRLEN; l++) {
222 *(ivalp++) = 0;
223 }
224 }
225 break;
226 case PRJ_W:
227 for (m = 0; m < 10; m++) {
228 *(dvalp++) = prjp->w[m];
229 }
230 break;
231 case PRJ_N:
232 *ivalp = prjp->n;
233 break;
234 default:
235 return 1;
236 }
237
238 return 0;
239 }
240
prjgtc_(const int * prj,const int * what,char * value)241 int prjgtc_(const int *prj, const int *what, char *value)
242 {
243 return prjget_(prj, what, value);
244 }
245
prjgtd_(const int * prj,const int * what,double * value)246 int prjgtd_(const int *prj, const int *what, double *value)
247 {
248 return prjget_(prj, what, value);
249 }
250
prjgti_(const int * prj,const int * what,int * value)251 int prjgti_(const int *prj, const int *what, int *value)
252 {
253 return prjget_(prj, what, value);
254 }
255
256 //----------------------------------------------------------------------------
257
prjini_(int * prj)258 int prjini_(int *prj)
259
260 {
261 return prjini((struct prjprm *)prj);
262 }
263
264 //----------------------------------------------------------------------------
265
prjfree_(int * prj)266 int prjfree_(int *prj)
267
268 {
269 return prjfree((struct prjprm *)prj);
270 }
271
272 //----------------------------------------------------------------------------
273
prjsize_(const int * prj,int sizes[2])274 int prjsize_(const int *prj, int sizes[2])
275
276 {
277 return prjsize((const struct prjprm *)prj, sizes);
278 }
279
280 //----------------------------------------------------------------------------
281
prjprt_(const int * prj)282 int prjprt_(const int *prj)
283
284 {
285 // This may or may not force the Fortran I/O buffers to be flushed. If
286 // not, try CALL FLUSH(6) before calling PRJPRT in the Fortran code.
287 fflush(NULL);
288
289 return prjprt((const struct prjprm *)prj);
290 }
291
292 //----------------------------------------------------------------------------
293
294 // If null-terminated (using the Fortran CHAR(0) intrinsic), prefix may be of
295 // length less than but not exceeding 72 and trailing blanks are preserved.
296 // Otherwise, it must be of length 72 and trailing blanks are stripped off.
297
prjperr_(int * prj,const char prefix[72])298 int prjperr_(int *prj, const char prefix[72])
299
300 {
301 char prefix_[73];
302 wcsutil_strcvt(72, '\0', 1, prefix, prefix_);
303
304 // This may or may not force the Fortran I/O buffers to be flushed.
305 // If not, try CALL FLUSH(6) before calling PRJPERR in the Fortran code.
306 fflush(NULL);
307
308 return wcserr_prt(((struct prjprm *)prj)->err, prefix_);
309 }
310
311 //----------------------------------------------------------------------------
312
prjbchk_(const double * tol,const int * nphi,const int * ntheta,const int * spt,double phi[],double theta[],int stat[])313 int prjbchk_(
314 const double *tol,
315 const int *nphi,
316 const int *ntheta,
317 const int *spt,
318 double phi[],
319 double theta[],
320 int stat[])
321
322 {
323 return prjbchk(*tol, *nphi, *ntheta, *spt, phi, theta, stat);
324 }
325
326 //----------------------------------------------------------------------------
327
328 #define PRJSET_FWRAP(pcode, PCODE) \
329 int F77_FUNC(pcode##set, PCODE##SET)(int *prj) \
330 {return prjset((struct prjprm *)prj);}
331
332
333 #define PRJS2X_FWRAP(pcode, PCODE) \
334 int F77_FUNC(pcode##s2x, PCODE##S2X)( \
335 int *prj, \
336 const int *nphi, \
337 const int *ntheta, \
338 const int *spt, \
339 const int *sxy, \
340 const double phi[], \
341 const double theta[], \
342 double x[], \
343 double y[], \
344 int stat[]) \
345 {return prj##s2x((struct prjprm *)prj, *nphi, *ntheta, *spt, *sxy, \
346 phi, theta, x, y, stat);}
347
348 #define PRJX2S_FWRAP(pcode, PCODE) \
349 int F77_FUNC(pcode##x2s, PRJ##X2S)( \
350 int *prj, \
351 const int *nx, \
352 const int *ny, \
353 const int *sxy, \
354 const int *spt, \
355 const double x[], \
356 const double y[], \
357 double phi[], \
358 double theta[], \
359 int stat[]) \
360 {return pcode##x2s((struct prjprm *)prj, *nx, *ny, *sxy, *spt, x, y, \
361 phi, theta, stat);}
362
363 #define PRJ_FWRAP(pcode, PCODE) \
364 PRJSET_FWRAP(pcode, PCODE) \
365 PRJS2X_FWRAP(pcode, PCODE) \
366 PRJX2S_FWRAP(pcode, PCODE)
367
368 PRJ_FWRAP(prj, PRJ)
369 PRJ_FWRAP(azp, AZP)
370 PRJ_FWRAP(szp, SZP)
371 PRJ_FWRAP(tan, TAN)
372 PRJ_FWRAP(stg, STG)
373 PRJ_FWRAP(sin, SIN)
374 PRJ_FWRAP(arc, ARC)
375 PRJ_FWRAP(zpn, ZPN)
376 PRJ_FWRAP(zea, ZEA)
377 PRJ_FWRAP(air, AIR)
378 PRJ_FWRAP(cyp, CYP)
379 PRJ_FWRAP(cea, CEA)
380 PRJ_FWRAP(car, CAR)
381 PRJ_FWRAP(mer, MER)
382 PRJ_FWRAP(sfl, SFL)
383 PRJ_FWRAP(par, PAR)
384 PRJ_FWRAP(mol, MOL)
385 PRJ_FWRAP(ait, AIT)
386 PRJ_FWRAP(cop, COP)
387 PRJ_FWRAP(coe, COE)
388 PRJ_FWRAP(cod, COD)
389 PRJ_FWRAP(coo, COO)
390 PRJ_FWRAP(bon, BON)
391 PRJ_FWRAP(pco, PCO)
392 PRJ_FWRAP(tsc, TSC)
393 PRJ_FWRAP(csc, CSC)
394 PRJ_FWRAP(qsc, QSC)
395 PRJ_FWRAP(hpx, HPX)
396 PRJ_FWRAP(xph, XPH)
397