SINFONI Pipeline Reference Manual  2.5.2
sinfo_baryvel.c
1 /* *
2  * This file is part of the ESO SINFONI Pipeline *
3  * Copyright (C) 2004,2005 European Southern Observatory *
4  * *
5  * This library is free software; you can redistribute it and/or modify *
6  * it under the terms of the GNU General Public License as published by *
7  * the Free Software Foundation; either version 2 of the License, or *
8  * (at your option) any later version. *
9  * *
10  * This program is distributed in the hope that it will be useful, *
11  * but WITHOUT ANY WARRANTY; without even the implied warranty of *
12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
13  * GNU General Public License for more details. *
14  * *
15  * You should have received a copy of the GNU General Public License *
16  * along with this program; if not, write to the Free Software *
17  * Foundation, 51 Franklin St, Fifth Floor, Boston, MA 02111-1307 USA *
18  * */
19 
20 /*
21  * $Author: amodigli $
22  * $Date: 2012-03-02 08:42:20 $
23  * $Revision: 1.3 $
24  * $Name: not supported by cvs2svn $
25  * $Log: not supported by cvs2svn $
26  * Revision 1.2 2009/04/28 11:42:18 amodigli
27  * now return cpl_error_code
28  *
29  * Revision 1.1 2009/01/02 08:27:58 amodigli
30  * added to repository
31  *
32  * Revision 1.8 2007/06/06 08:17:33 amodigli
33  * replace tab with 4 spaces
34  *
35  */
36 
37 #ifdef HAVE_CONFIG_H
38 # include <config.h>
39 #endif
40 
41 
43 /*---------------------------------------------------------------------------*/
57 /*---------------------------------------------------------------------------*/
58 
59 /*----------------------------------------------------------------------------
60  Includes
61  ---------------------------------------------------------------------------*/
62 
63 #include <sinfo_baryvel.h>
64 
65 #include <sinfo_pfits.h>
66 #include <sinfo_utils.h>
67 #include <sinfo_error.h>
68 #include <sinfo_msg.h>
69 #include <sinfo_functions.h>
70 
71 #include <cpl.h>
72 
73 #include <math.h>
74 
75 #define H_GEOLAT "ESO TEL GEOLAT"
76 #define H_GEOLON "ESO TEL GEOLON"
77 #define H_UTC "UTC"
78 
79 /*-----------------------------------------------------------------------------
80  Local functions
81  ---------------------------------------------------------------------------*/
82 
83 static double sinfo_pfits_get_geolat(const cpl_propertylist * plist);
84 static double sinfo_pfits_get_geolon(const cpl_propertylist * plist);
85 static double sinfo_pfits_get_utc(const cpl_propertylist * plist);
86 
87 
88 
89 static void deg2dms(double in_val,
90  double *degs,
91  double *minutes,
92  double *seconds);
93 
94 static void deg2hms(double in_val,
95  double *hour,
96  double *min,
97  double *sec);
98 
99 static void compxy(double inputr[19], char inputc[4],
100  double outputr[4],
101  double utr, double mod_juldat);
102 
103 static void barvel(double DJE, double DEQ,
104  double DVELH[4], double DVELB[4]);
105 
106 
107 
108 
109 /*--------------------------------------------------------------------------*/
110 
111 /*--------------------------------------------------------------------------*/
117 /*--------------------------------------------------------------------------*/
118 static double sinfo_pfits_get_geolat(const cpl_propertylist * plist)
119 {
120  double returnvalue = 0;
121 
122  check(returnvalue=cpl_propertylist_get_double(plist, H_GEOLAT),
123  "Error reading keyword '%s'", H_GEOLAT);
124 
125  cleanup:
126  return returnvalue;
127 }
128 
129 /*--------------------------------------------------------------------------*/
135 /*--------------------------------------------------------------------------*/
136 static double sinfo_pfits_get_geolon(const cpl_propertylist * plist)
137 {
138  double returnvalue = 0;
139 
140  check(returnvalue=cpl_propertylist_get_double(plist, H_GEOLON),
141  "Error reading keyword '%s'", H_GEOLON);
142 
143  cleanup:
144  return returnvalue;
145 }
146 
147 
148 
149 
150 /*---------------------------------------------------------------------------*/
156 /*---------------------------------------------------------------------------*/
157 static double sinfo_pfits_get_utc(const cpl_propertylist * plist)
158 {
159  double returnvalue = 0;
160 
161  check(returnvalue=cpl_propertylist_get_double(plist, H_UTC),
162  "Error reading keyword '%s'", H_UTC);
163 
164  cleanup:
165  return returnvalue;
166 }
167 
168 
169 
170 #if 0 /* Not used / needed.
171  We simply get the julian date from the input FITS header */
172 
173 // SUBROUTINE JULDAT(INDATE,UTR,JD)
174 //C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
175 //C
176 //C.IDENTIFICATION
177 //C FORTRAN subroutine JULDAT version 1.0 870102
178 //C original coding: D. Gillet ESO - Garching
179 //C variables renamed and restructured: D. Baade ST-ECF, Garching
180 //C
181 //C.KEYWORDS
182 //C geocentric Julian date
183 //C
184 //C.PURPOSE
185 //C calculate geocentric Julian date for any civil date (time in UT)
186 //C
187 //C.ALGORITHM
188 //C adapted from MEEUS J.,1980, ASTRONOMICAL FORMULAE FOR CALCULATORS
189 //C
190 //C.INPUT/OUTPUT
191 //C the following are passed from and to the calling program:
192 //C INDATE(3) : civil date as year,month,day OR year.fraction
193 //C UT : universal time expressed in real hours
194 //C JD : real geocentric Julian date
195 //C
196 //C.REVISIONS
197 //C made to accept also REAL dates D. Baade 910408
198 //C
199 //C---------------------------------------------------------------------------
200 //C
201 
202 static void
203 juldat(double *INDATE,
204  double UTR,
205  double *JD)
206 {
207  double UT;
208 
209  int DATE[4];
210 
211  UT=UTR / 24.0;
212 
213  /*
214  CHECK FORMAT OF DATE: may be either year,month,date OR year.fraction,0,0
215  (Note that the fraction of the year must NOT include fractions of a day.)
216  For all other formats exit and terminate also calling command sequence.
217 
218  IF ((INDATE(1)-INT(INDATE(1))).GT.1.0E-6) THEN
219  IF ((INDATE(2).GT.1.0E-6).OR.(INDATE(3).GT.1.0E-6))
220  + CALL STETER(1,'Error: Date was entered in wrong format.')
221 
222  copy date input buffer copy to other buffer so that calling program
223  does not notice any changes
224 
225  FIRST CASE: format was year.fraction
226 
227  DATE(1)=INT(INDATE(1))
228  FRAC=INDATE(1)-DATE(1)
229  DATE(2)=1
230  DATE(3)=1
231  ELSE
232 
233  SECOND CASE: format was year,month,day
234  */
235 
236  DATE[1]=sinfo_round_double(INDATE[1]);
237 
238  FRAC = 0;
239 
240  DATE[2]=sinfo_round_double(INDATE[2]);
241 
242  DATE[3]=sinfo_round_double(INDATE[3]);
243 
244  if ((DATE[2] == 0) && (DATE[3] == 0)) {
245 
246  DATE[2]=1;
247 
248  DATE[3]=1;
249 
250  }
251 
252  /*
253  from here on, the normal procedure applies which is based on the
254  format year,month,day:
255  */
256  if (DATE[2] > 2) {
257  YP=DATE[1];
258  P=DATE[2];
259  } else {
260  YP=DATE[1]-1;
261  P=DATE(2)+12.0;
262  }
263 
264  C = DATE[1] + DATE[2]*1.E-2 + DATE[3]*1.E-4 + UT*1.E-6;
265 
266  if (C > 1582.1015E0) {
267  IA=(int) (YP/100.D0);
268  A=IA;
269  IB=2-IA+((int)(A/4.D0));
270  } else {
271  IB=0;
272  }
273 
274  *JD = ((int) (365.25E0*YP)) + ((int)(30.6001D0*(P+1.D0))) + DATE[3] + UT
275  + IB + 1720994.5E0;
276 
277  /*
278  finally, take into account fraction of year (if any), respect leap
279  year conventions
280  */
281  if (FRAC > 1.0E-6) {
282  ND=365;
283 
284  IF (C >= 1582.1015E0) {
285  IC = DATE[1] % 4;
286  if (IC == 0) {
287  ND=366;
288  IC = DATE[1] % 100;
289  if (IC == 0) {
290  IC = DATE[1] % 400;
291  if (IC != 0) ND=365;
292  }
293  }
294  }
295 
296  if (fabs(FRAC*ND-sinfo_round_double(FRAC*ND)) > 0.3) {
297  sinfo_msg_warning("Fraction of year MAY not correspond to "
298  "integer number of days");
299  }
300 
301  *JD = *JD+sinfo_round_double(FRAC*ND);
302  }
303 
304  return;
305 }
306 
307 #endif
308 
312 #define MIDAS_BUG 0
313 /*---------------------------------------------------------------------------*/
321 /*---------------------------------------------------------------------------*/
322 
323 static void
324 deg2hms(double in_val,
325  double *hours,
326  double *minutes,
327  double *seconds)
328 {
329  double tmp;
330  char sign;
331  if (in_val < 0) {
332  in_val = fabs(in_val);
333  sign = '-';
334  }
335  else {
336  sign = '+';
337  }
338 
339  tmp = in_val / 15;
340 
341  /* takes the integer part = hours */
342 #if MIDAS_BUG
343  *hours= sinfo_round_double(tmp);
344 #else
345  *hours= (int) tmp;
346 #endif
347 
348  /* takes the mantissa */
349  tmp = tmp - *hours;
350  /* converts the mantissa in minutes */
351  tmp = tmp * 60;
352 
353  /* takes the integer part = minutes */
354 #if MIDAS_BUG
355  *minutes= sinfo_round_double(tmp);
356 #else
357  *minutes= (int) tmp;
358 #endif
359 
360  /* takes the mantissa */
361  tmp = tmp - *minutes;
362 
363  /* converts the mantissa in seconds = seconds (with decimal) */
364  *seconds= tmp * 60;
365 
366  /* Rather than returning it explicitly, just attach sign to hours */
367  if (sign == '-') *hours = -(*hours);
368 
369  return;
370 }
371 
372 /*---------------------------------------------------------------------------*/
380 /*---------------------------------------------------------------------------*/
381 
382 static void
383 deg2dms(double in_val,
384  double *degs,
385  double *minutes,
386  double *seconds)
387 {
388  deg2hms(in_val*15, degs, minutes, seconds);
389 }
390 
391 
392 
393 
394 
395 /* @cond Convert FORTRAN indexing -> C indexing */
396 #define DCFEL(x,y) dcfel[y][x]
397 #define DCFEPS(x,y) dcfeps[y][x]
398 #define CCSEL(x,y) ccsel[y][x]
399 #define DCARGS(x,y) dcargs[y][x]
400 #define CCAMPS(x,y) ccamps[y][x]
401 #define CCSEC(x,y) ccsec[y][x]
402 #define DCARGM(x,y) dcargm[y][x]
403 #define CCAMPM(x,y) ccampm[y][x]
404 #define DCEPS(x) dceps[x]
405 #define FORBEL(x) forbel[x]
406 #define SORBEL(x) sorbel[x]
407 #define SN(x) sn[x]
408 #define SINLP(x) sinlp[x]
409 #define COSLP(x) coslp[x]
410 #define CCPAMV(x) ccpamv[x]
411 /* @endcond */
412 /*---------------------------------------------------------------------------*/
425 /*---------------------------------------------------------------------------*/
426 
427 
428 static
429 void barvel(double DJE, double DEQ,
430  double DVELH[4], double DVELB[4])
431 {
432  double sn[5];
433  double DT,DTL,DTSQ,DLOCAL;
434  double DRD,DRLD;
435  double DXBD,DYBD,DZBD,DZHD,DXHD,DYHD;
436  double DYAHD,DZAHD,DYABD,DZABD;
437  double DML,DEPS,PHI,PHID,PSID,DPARAM,PARAM;
438  double PLON,POMG,PECC;
439  double PERTL,PERTLD,PERTRD,PERTP,PERTR,PERTPD;
440  double SINA,TL;
441  double COSA,ESQ;
442  double A,B,F,SINF,COSF,T,TSQ,TWOE,TWOG;
443 
444  double DPSI,D1PDRO,DSINLS;
445  double DCOSLS,DSINEP,DCOSEP;
446  double forbel[8], sorbel[18], sinlp[5], coslp[5];
447  double SINLM,COSLM,SIGMA;
448  /* int IDEQ; */
449  int K,N;
450 
451  double *E = sorbel + 1 - 1;
452  double *G = forbel + 1 - 1;
453  double DC2PI = 6.2831853071796E0;
454  double CC2PI = 6.283185; /* ??? */
455 
456  double DC1 = 1.0;
457  double DCT0 = 2415020.0E0;
458  double DCJUL = 36525.0E0;
459 
460  double dcfel[][4] = { {0, 0, 0, 0},
461  {0, 1.7400353E+00, 6.2833195099091E+02, 5.2796E-06},
462  {0, 6.2565836E+00, 6.2830194572674E+02,-2.6180E-06},
463  {0, 4.7199666E+00, 8.3997091449254E+03,-1.9780E-05},
464  {0, 1.9636505E-01, 8.4334662911720E+03,-5.6044E-05},
465  {0, 4.1547339E+00, 5.2993466764997E+01, 5.8845E-06},
466  {0, 4.6524223E+00, 2.1354275911213E+01, 5.6797E-06},
467  {0, 4.2620486E+00, 7.5025342197656E+00, 5.5317E-06},
468  {0, 1.4740694E+00, 3.8377331909193E+00, 5.6093E-06} };
469 
470  double dceps[4] = {0, 4.093198E-01,-2.271110E-04,-2.860401E-08};
471 
472  double ccsel[][4] = { {0, 0, 0, 0},
473  {0, 1.675104E-02, -4.179579E-05, -1.260516E-07},
474  {0, 2.220221E-01, 2.809917E-02, 1.852532E-05},
475  {0, 1.589963E+00, 3.418075E-02, 1.430200E-05},
476  {0, 2.994089E+00, 2.590824E-02, 4.155840E-06},
477  {0, 8.155457E-01, 2.486352E-02, 6.836840E-06},
478  {0, 1.735614E+00, 1.763719E-02, 6.370440E-06},
479  {0, 1.968564E+00, 1.524020E-02, -2.517152E-06},
480  {0, 1.282417E+00, 8.703393E-03, 2.289292E-05},
481  {0, 2.280820E+00, 1.918010E-02, 4.484520E-06},
482  {0, 4.833473E-02, 1.641773E-04, -4.654200E-07},
483  {0, 5.589232E-02, -3.455092E-04, -7.388560E-07},
484  {0, 4.634443E-02, -2.658234E-05, 7.757000E-08},
485  {0, 8.997041E-03, 6.329728E-06, -1.939256E-09},
486  {0, 2.284178E-02, -9.941590E-05, 6.787400E-08},
487  {0, 4.350267E-02, -6.839749E-05, -2.714956E-07},
488  {0, 1.348204E-02, 1.091504E-05, 6.903760E-07},
489  {0, 3.106570E-02, -1.665665E-04, -1.590188E-07} };
490 
491 
492  double dcargs[][3] = { {0, 0, 0},
493  {0, 5.0974222E+00, -7.8604195454652E+02},
494  {0, 3.9584962E+00, -5.7533848094674E+02},
495  {0, 1.6338070E+00, -1.1506769618935E+03},
496  {0, 2.5487111E+00, -3.9302097727326E+02},
497  {0, 4.9255514E+00, -5.8849265665348E+02},
498  {0, 1.3363463E+00, -5.5076098609303E+02},
499  {0, 1.6072053E+00, -5.2237501616674E+02},
500  {0, 1.3629480E+00, -1.1790629318198E+03},
501  {0, 5.5657014E+00, -1.0977134971135E+03},
502  {0, 5.0708205E+00, -1.5774000881978E+02},
503  {0, 3.9318944E+00, 5.2963464780000E+01},
504  {0, 4.8989497E+00, 3.9809289073258E+01},
505  {0, 1.3097446E+00, 7.7540959633708E+01},
506  {0, 3.5147141E+00, 7.9618578146517E+01},
507  {0, 3.5413158E+00, -5.4868336758022E+02} };
508 
509 
510  double ccamps[][6] =
511  {{0, 0, 0, 0, 0, 0},
512  {0, -2.279594E-5, 1.407414E-5, 8.273188E-6, 1.340565E-5, -2.490817E-7},
513  {0, -3.494537E-5, 2.860401E-7, 1.289448E-7, 1.627237E-5, -1.823138E-7},
514  {0, 6.593466E-7, 1.322572E-5, 9.258695E-6, -4.674248E-7, -3.646275E-7},
515  {0, 1.140767E-5, -2.049792E-5, -4.747930E-6, -2.638763E-6, -1.245408E-7},
516  {0, 9.516893E-6, -2.748894E-6, -1.319381E-6, -4.549908E-6, -1.864821E-7},
517  {0, 7.310990E-6, -1.924710E-6, -8.772849E-7, -3.334143E-6, -1.745256E-7},
518  {0, -2.603449E-6, 7.359472E-6, 3.168357E-6, 1.119056E-6, -1.655307E-7},
519  {0, -3.228859E-6, 1.308997E-7, 1.013137E-7, 2.403899E-6, -3.736225E-7},
520  {0, 3.442177E-7, 2.671323E-6, 1.832858E-6, -2.394688E-7, -3.478444E-7},
521  {0, 8.702406E-6, -8.421214E-6, -1.372341E-6, -1.455234E-6, -4.998479E-8},
522  {0, -1.488378E-6, -1.251789E-5, 5.226868E-7, -2.049301E-7, 0.0E0},
523  {0, -8.043059E-6, -2.991300E-6, 1.473654E-7, -3.154542E-7, 0.0E0},
524  {0, 3.699128E-6, -3.316126E-6, 2.901257E-7, 3.407826E-7, 0.0E0},
525  {0, 2.550120E-6, -1.241123E-6, 9.901116E-8, 2.210482E-7, 0.0E0},
526  {0, -6.351059E-7, 2.341650E-6, 1.061492E-6, 2.878231E-7, 0.0E0}};
527 
528 
529 
530  double CCSEC3 = -7.757020E-08;
531 
532  double ccsec[][4] = { {0, 0, 0, 0},
533  {0, 1.289600E-06, 5.550147E-01, 2.076942E+00},
534  {0, 3.102810E-05, 4.035027E+00, 3.525565E-01},
535  {0, 9.124190E-06, 9.990265E-01, 2.622706E+00},
536  {0, 9.793240E-07, 5.508259E+00, 1.559103E+01}};
537 
538  double DCSLD = 1.990987E-07, CCSGD = 1.990969E-07;
539 
540  double CCKM = 3.122140E-05, CCMLD = 2.661699E-06, CCFDI = 2.399485E-07;
541 
542  double dcargm[][3] = {{0, 0, 0},
543  {0, 5.1679830E+00, 8.3286911095275E+03},
544  {0, 5.4913150E+00, -7.2140632838100E+03},
545  {0, 5.9598530E+00, 1.5542754389685E+04}};
546 
547  double ccampm[][5] = {{0, 0, 0, 0, 0},
548  {0, 1.097594E-01, 2.896773E-07, 5.450474E-02, 1.438491E-07},
549  {0, -2.223581E-02, 5.083103E-08, 1.002548E-02, -2.291823E-08},
550  {0, 1.148966E-02, 5.658888E-08, 8.249439E-03, 4.063015E-08} };
551 
552  double ccpamv[] = {0, 8.326827E-11, 1.843484E-11, 1.988712E-12, 1.881276E-12};
553 
554  double DC1MME = 0.99999696E0;
555 
556  /* not used later
557  * IDEQ=DEQ; */
558 
559 
560  DT=(DJE-DCT0)/DCJUL;
561 
562  T=DT;
563 
564  DTSQ=DT*DT;
565 
566  TSQ=DTSQ;
567 
568  DML = 0; /* Suppress warning */
569  for (K = 1; K <= 8; K++) {
570 
571  DLOCAL=fmod(DCFEL(1,K)+DT*DCFEL(2,K)+DTSQ*DCFEL(3,K),DC2PI);
572 
573  if (K == 1) DML=DLOCAL;
574 
575  if (K != 1) FORBEL(K-1)=DLOCAL;
576  }
577 
578  DEPS=fmod(DCEPS(1)+DT*DCEPS(2)+DTSQ*DCEPS(3), DC2PI);
579 
580  for (K = 1; K <= 17; K++) {
581 
582  SORBEL(K)=fmod(CCSEL(1,K)+T*CCSEL(2,K)+TSQ*CCSEL(3,K),CC2PI);
583 
584  }
585 
586  for (K = 1; K <= 4; K++) {
587 
588  A=fmod(CCSEC(2,K)+T*CCSEC(3,K),CC2PI);
589 
590  SN(K)=sin(A);
591 
592  }
593 
594  PERTL = CCSEC(1,1) *SN(1) +CCSEC(1,2)*SN(2)
595  +(CCSEC(1,3)+T*CCSEC3)*SN(3) +CCSEC(1,4)*SN(4);
596 
597  PERTLD=0.0;
598  PERTR =0.0;
599  PERTRD=0.0;
600 
601  for (K = 1; K <= 15; K++) {
602 
603  A=fmod(DCARGS(1,K)+DT*DCARGS(2,K), DC2PI);
604 
605  COSA=cos(A);
606 
607  SINA=sin(A);
608 
609  PERTL =PERTL+CCAMPS(1,K)*COSA+CCAMPS(2,K)*SINA;
610 
611  PERTR =PERTR+CCAMPS(3,K)*COSA+CCAMPS(4,K)*SINA;
612 
613  if (K >= 11) break;
614 
615  PERTLD=PERTLD+(CCAMPS(2,K)*COSA-CCAMPS(1,K)*SINA)*CCAMPS(5,K);
616 
617  PERTRD=PERTRD+(CCAMPS(4,K)*COSA-CCAMPS(3,K)*SINA)*CCAMPS(5,K);
618 
619  }
620 
621 
622  ESQ=E[1]*E[1];
623 
624  DPARAM=DC1-ESQ;
625 
626  PARAM=DPARAM;
627 
628  TWOE=E[1]+E[1];
629 
630  TWOG=G[1]+G[1];
631 
632  PHI=TWOE*((1.0-ESQ*0.125 )*sin(G[1])+E[1]*0.625 *sin(TWOG)
633  +ESQ*0.5416667 *sin(G[1]+TWOG) ) ;
634 
635  F=G[1]+PHI;
636 
637  SINF=sin(F);
638 
639  COSF=cos(F);
640 
641  DPSI=DPARAM/(DC1+E[1]*COSF);
642 
643  PHID=TWOE*CCSGD*((1.0+ESQ*1.5 )*COSF+E[1]*(1.25 -SINF*SINF*0.5 ));
644 
645  PSID=CCSGD*E[1]*SINF/sqrt(PARAM);
646 
647  D1PDRO=(DC1+PERTR);
648 
649  DRD=D1PDRO*(PSID+DPSI*PERTRD);
650 
651  DRLD=D1PDRO*DPSI*(DCSLD+PHID+PERTLD);
652 
653  DTL=fmod(DML+PHI+PERTL, DC2PI);
654 
655  DSINLS=sin(DTL);
656 
657  DCOSLS=cos(DTL);
658 
659  DXHD = DRD*DCOSLS-DRLD*DSINLS;
660 
661  DYHD = DRD*DSINLS+DRLD*DCOSLS;
662 
663  PERTL =0.0;
664 
665  PERTLD=0.0;
666 
667  PERTP =0.0;
668 
669  PERTPD=0.0;
670 
671  for (K = 1; K <= 3; K++) {
672  A=fmod(DCARGM(1,K)+DT*DCARGM(2,K), DC2PI);
673 
674  SINA =sin(A);
675 
676  COSA =cos(A);
677 
678  PERTL =PERTL +CCAMPM(1,K)*SINA;
679 
680  PERTLD=PERTLD+CCAMPM(2,K)*COSA;
681 
682  PERTP =PERTP +CCAMPM(3,K)*COSA;
683 
684  PERTPD=PERTPD-CCAMPM(4,K)*SINA;
685  }
686 
687  TL=FORBEL(2)+PERTL;
688 
689  SINLM=sin(TL);
690 
691  COSLM=cos(TL);
692 
693  SIGMA=CCKM/(1.0+PERTP);
694 
695  A=SIGMA*(CCMLD+PERTLD);
696 
697  B=SIGMA*PERTPD;
698 
699  DXHD=DXHD+A*SINLM+B*COSLM;
700 
701  DYHD=DYHD-A*COSLM+B*SINLM;
702 
703  DZHD= -SIGMA*CCFDI* cos(FORBEL(3));
704 
705  DXBD=DXHD*DC1MME;
706 
707  DYBD=DYHD*DC1MME;
708 
709  DZBD=DZHD*DC1MME;
710 
711  for (K = 1; K <= 4; K++) {
712 
713  PLON=FORBEL(K+3);
714 
715  POMG=SORBEL(K+1);
716 
717  PECC=SORBEL(K+9);
718 
719  TL=fmod(PLON+2.0*PECC* sin(PLON-POMG), CC2PI);
720 
721  SINLP(K)= sin(TL);
722 
723  COSLP(K)= cos(TL);
724 
725  DXBD=DXBD+CCPAMV(K)*(SINLP(K)+PECC*sin(POMG));
726 
727  DYBD=DYBD-CCPAMV(K)*(COSLP(K)+PECC*cos(POMG));
728 
729  DZBD=DZBD-CCPAMV(K)*SORBEL(K+13)*cos(PLON-SORBEL(K+5));
730 
731  }
732 
733  DCOSEP=cos(DEPS);
734  DSINEP=sin(DEPS);
735  DYAHD=DCOSEP*DYHD-DSINEP*DZHD;
736  DZAHD=DSINEP*DYHD+DCOSEP*DZHD;
737  DYABD=DCOSEP*DYBD-DSINEP*DZBD;
738  DZABD=DSINEP*DYBD+DCOSEP*DZBD;
739 
740  DVELH[1]=DXHD;
741  DVELH[2]=DYAHD;
742  DVELH[3]=DZAHD;
743 
744  DVELB[1]=DXBD;
745  DVELB[2]=DYABD;
746  DVELB[3]=DZABD;
747 
748  for (N = 1; N <= 3; N++) {
749  DVELH[N]=DVELH[N]*1.4959787E8;
750  DVELB[N]=DVELB[N]*1.4959787E8;
751  }
752  return;
753 }
754 
755 
756 
757 
758 /*--------------------------------------------------------------------------*/
780 /*--------------------------------------------------------------------------*/
781 static void
782 compxy(double inputr[19], char inputc[4],
783  double outputr[4],
784  double utr, double mod_juldat)
785 {
786  double STR;
787  double t0, dl, theta0, pe, st0hg, stg;
788  double jd, jd0h;
789  double dvelb[4], dvelh[4];
790  double alp, del, beov, berv, EDV;
791  double HAR, phi, heov, herv;
792  double *rbuf;
793  char inpsgn[4];
794  double *olong, *olat, *alpha, *delta;
795  char signs[] = "+++";
796  rbuf = inputr;
797  inpsgn[1] = inputc[1];
798  inpsgn[2] = inputc[2];
799  inpsgn[3] = inputc[3];
800  olong = rbuf + 7 - 1;
801  olat = rbuf + 10 - 1;
802  alpha = rbuf + 13 - 1;
803  delta = rbuf + 16 - 1;
804  // ... convert UT to real hours, calculate Julian date
805  /* We know this one already but convert seconds -> hours */
806  utr /= 3600;
807 
808 
809  jd = mod_juldat + 2400000.5;
810 
811  // ... likewise convert longitude and latitude of observatory to real hours
812  // ... and degrees, respectively; take care of signs
813  // ... NOTE: east longitude is assumed for input !!
814 
815  if (olong[1] < 0 || olong[2] < 0 ||
816  olong[3] < 0 || inpsgn[1] == '-') {
817  signs[1] = '-';
818  olong[1] = fabs(olong[1]);
819  olong[2] = fabs(olong[2]);
820  olong[3] = fabs(olong[3]);
821  }
822  dl = olong[1]+olong[2]/60. +olong[3]/3600.;
823  if (signs[1] == '-') dl = -dl;
824  dl = -dl*24. /360.;
825 
826  if (olat[1] < 0 || olat[2] < 0 ||
827  olat[3] < 0 || inpsgn[2] == '-') {
828  signs[2] = '-';
829 
830  olat[1] = fabs(olat[1]);
831  olat[2] = fabs(olat[2]);
832  olat[3] = fabs(olat[3]);
833 
834  }
835 
836  phi = olat[1]+olat[2]/60. +olat[3]/3600.;
837 
838  if (signs[2] == '-') phi = -phi;
839 
840  phi = phi*M_PI/180. ;
841 
842  // ... convert right ascension and declination to real radians
843 
844  alp = (alpha[1]*3600. +alpha[2]*60. +alpha[3])*M_PI/(12. *3600. );
845 
846  if (delta[1] < 0 || delta[2] < 0 ||
847  delta[3] < 0 || inpsgn[3] == '-') {
848 
849  signs[3] = '-';
850 
851  delta[1] = fabs(delta[1]);
852  delta[2] = fabs(delta[2]);
853  delta[3] = fabs(delta[3]);
854 
855  }
856 
857  del = (delta[1]*3600.0 + delta[2]*60. + delta[3])
858  * M_PI/(3600. *180. );
859 
860 
861 
862  if (signs[3] == '-') del = - del;
863 
864  // ... calculate earth's orbital velocity in rectangular coordinates X,Y,Z
865  // ... for both heliocentric and barycentric frames (DVELH, DVELB)
866  // ... Note that setting the second argument of BARVEL to zero as done below
867  // ... means that the input coordinates will not be corrected for precession.
868 
869 
870  barvel(jd, 0.0, dvelh, dvelb);
871 
872  // ... with the rectangular velocity components known, the respective projections
873  // ... HEOV and BEOV on a given line of sight (ALP,DEL) can be determined:
874 
875  // ... REFERENCE: THE ASTRONOMICAL ALMANAC 1982 PAGE:B17
876 
877  beov =
878  dvelb[1]*cos(alp)*cos(del)+
879  dvelb[2]*sin(alp)*cos(del)+
880  dvelb[3]*sin(del);
881 
882  heov =
883  dvelh[1]*cos(alp)*cos(del)+
884  dvelh[2]*sin(alp)*cos(del)+
885  dvelh[3]*sin(del);
886 
887 
888  // ... For determination also of the contribution due to the diurnal rotation of
889  // ... the earth (EDV), the hour angle (HAR) is needed at which the observation
890  // ... was made which requires conversion of UT to sidereal time (ST).
891 
892  // ... Therefore, first compute ST at 0 hours UT (ST0HG)
893 
894  // ... REFERENCE : MEEUS J.,1980,ASTRONOMICAL FORMULAE FOR CALCULATORS
895 
896 
897  jd0h = jd - (utr/24.0);
898 
899  t0 = (jd0h-2415020. )/36525. ;
900 
901 
902  theta0 = 0.276919398 +100.0021359 *t0+0.000001075 *t0*t0 ;
903 
904  pe = (int) theta0;
905 
906  theta0 = theta0 - pe;
907 
908  st0hg = theta0*24. ;
909 
910  // ... now do the conversion UT -> ST (MEAN SIDEREAL TIME)
911 
912  // ... REFERENCE : THE ASTRONOMICAL ALMANAC 1983, P B7
913  // ... IN 1983: 1 MEAN SOLAR DAY = 1.00273790931 MEAN SIDEREAL DAYS
914  // ... ST WITHOUT EQUATION OF EQUINOXES CORRECTION => ACCURACY +/- 1 SEC
915  //
916  stg = st0hg+utr*1.00273790931 ;
917 
918  if (stg < dl) stg = stg +24. ;
919 
920  STR = stg-dl;
921 
922 
923  if (STR >= 24. ) STR = STR-24. ;
924 
925  STR = STR*M_PI/12. ;
926 
927  HAR = STR-alp;
928 
929 
930  EDV = -0.4654 * sin(HAR)* cos(del)* cos(phi);
931 
932  // ... the total correction (in km/s) is the sum of orbital and diurnal components
933 
934 
935  herv=heov+EDV;
936  berv=beov+EDV;
937 
938  /* The following is not needed. Do not translate */
939 
940 #if 0
941  // ... Calculation of the barycentric and heliocentric correction times
942  // ... (BCT and HCT) requires knowledge of the earth's position in its
943  // ... orbit. Subroutine BARCOR returns the rectangular barycentric (DCORB)
944  // ... and heliocentric (DCORH) coordinates.
945 
946  // CALL BARCOR(DCORH,DCORB)
947 
948  // ... from this, the correction times (in days) can be determined:
949  // ... (REFERENCE: THE ASTRONOMICAL ALMANAC 1982 PAGE:B16)
950 
951  // BCT=+0.0057756D0*(DCORB(1)*DCOS(ALP)*DCOS(DEL)+
952  // 1 DCORB(2)*DSIN(ALP)*DCOS(DEL)+
953  // 2 DCORB(3)* DSIN(DEL))
954  // HCT=+0.0057756D0*(DCORH(1)*DCOS(ALP)*DCOS(DEL)+
955  // 1 DCORH(2)*DSIN(ALP)*DCOS(DEL)+
956  // 2 DCORH(3)* DSIN(DEL))
957 
958  //... write results to keywords
959 
960  // CALL STKWRD('OUTPUTD',BCT,1,1,KUN,STAT) ! barycentric correction time
961  // CALL STKWRD('OUTPUTD',HCT,2,1,KUN,STAT) ! heliocentric correction time
962 #endif
963 
964  rbuf[1] = berv; /* barocentric RV correction */
965  rbuf[2] = herv; /* heliocentric RV correction */
966  rbuf[3] = EDV; /* diurnal RV correction */
967 
968 
969  outputr[1] = rbuf[1];
970  outputr[2] = rbuf[2];
971  outputr[3] = rbuf[3];
972 
973  return;
974 }
975 
976 
977 
978 /*----------------------------------------------------------------------------*/
985 /*----------------------------------------------------------------------------*/
986 cpl_error_code
987 sinfo_baryvel(const cpl_propertylist *raw_header,
988  double *bary_corr,
989  double *helio_corr)
990 {
991 
992  double outputr[4];
993 
994  char inputc[] = "X+++"; /* 0th index not used */
995 
996  double rneg = 1.0;
997 
998  double inputr[19]; /* Do not use the zeroth element */
999 
1000 
1001 /*
1002  qc_ra = m$value({p1},O_POS(1))
1003  qc_dec = m$value({p1},O_POS(2))
1004  qc_geolat = m$value({p1},{h_geolat})
1005  qc_geolon = m$value({p1},{h_geolon})
1006  qc_obs_time = m$value({p1},O_TIME(7)) !using an image as input it take the
1007  !date from the descriptor O_TIME(1,2,3)
1008  !and the UT from O_TIME(5)
1009 */
1010  double qc_ra;
1011  double qc_dec;
1012  double qc_geolat;
1013  double qc_geolon;
1014 
1015  double utr;
1016  double mod_juldat;
1017 
1018  double ra_hour, ra_min, ra_sec;
1019  double dec_deg, dec_min, dec_sec;
1020  double lat_deg, lat_min, lat_sec;
1021  double lon_deg, lon_min, lon_sec;
1022 
1023  check( qc_ra = sinfo_pfits_get_ra(raw_header), /* in degrees */
1024  "Error getting object right ascension");
1025  check( qc_dec = sinfo_pfits_get_dec(raw_header),
1026  "Error getting object declination");
1027 
1028  check( qc_geolat = sinfo_pfits_get_geolat(raw_header),
1029  "Error getting telescope latitude");
1030  check( qc_geolon = sinfo_pfits_get_geolon(raw_header),
1031  "Error getting telescope longitude");
1032 
1033  /* double qc_obs_time = sinfo_pfits_get_exptime(raw_header); Not used! */
1034 
1035  check( utr = sinfo_pfits_get_utc(raw_header),
1036  "Error reading UTC");
1037  check( mod_juldat = sinfo_pfits_get_mjdobs(raw_header),
1038  "Error julian date");
1039 
1040  deg2hms(qc_ra, &ra_hour, &ra_min, &ra_sec);
1041  deg2dms(qc_dec, &dec_deg, &dec_min, &dec_sec);
1042  deg2dms(qc_geolat, &lat_deg, &lat_min, &lat_sec);
1043  deg2dms(qc_geolon, &lon_deg, &lon_min, &lon_sec);
1044 
1045 
1046  inputr[7] = lon_deg;
1047  inputr[8] = lon_min;
1048  inputr[9] = lon_sec;
1049 
1050 
1051  rneg = (inputr[7]*3600.)+(inputr[8]*60.)+inputr[9];
1052 
1053  inputc[1] = (lon_deg >= 0) ? '+' : '-';
1054 
1055  if (rneg < 0) inputc[1] = '-';
1056 
1057 
1058  inputr[10] = lat_deg;
1059  inputr[11] = lat_min;
1060  inputr[12] = lat_sec;
1061 
1062 
1063  rneg = (inputr[10]*3600.)+(inputr[11]*60.)+inputr[12];
1064 
1065  inputc[2] = (lat_deg >= 0) ? '+' : '-';
1066 
1067  if (rneg < 0) inputc[2] = '-';
1068 
1069 
1070  inputr[13] = ra_hour;
1071  inputr[14] = ra_min;
1072  inputr[15] = ra_sec;
1073 
1074 
1075  inputr[16] = dec_deg;
1076  inputr[17] = dec_min;
1077  inputr[18] = dec_sec;
1078 
1079 
1080  inputc[3] = (dec_deg >= 0) ? '+' : '-';
1081 
1082  rneg = (inputr[16]*3600.)+(inputr[17]*60.)+inputr[18];
1083 
1084  if (rneg < 0) inputc[3] = '-';
1085 
1086 
1087 //C INPUTR/R/1/3 date: year,month,day
1088 //C INPUTR/R/4/3 universal time: hour,min,sec
1089 //C INPUTR/R/7/3 EAST longitude of observatory: degree,min,sec !! NOTE
1090 //C INPUTR/R/10/3 latitude of observatory: degree,min,sec
1091 //C INPUTR/R/13/3 right ascension: hour,min,sec
1092 //C INPUTR/R/16/3 declination: degree,min,sec
1093 
1094  /* compute the corrections */
1095  compxy(inputr, inputc, outputr, utr, mod_juldat);
1096 
1097  sinfo_msg_debug(" Total barycentric RV correction: %f km/s", outputr[1]);
1098  sinfo_msg_debug(" Total heliocentric RV correction: %f km/s", outputr[2]);
1099  sinfo_msg_debug(" (incl. diurnal RV correction of %f km/s)", outputr[3]);
1100 
1101 
1102  *bary_corr = outputr[1];
1103  *helio_corr = outputr[2];
1104 
1105  cleanup:
1106  if (cpl_error_get_code() != CPL_ERROR_NONE) {
1107  sinfo_check_rec_status(0);
1108  }
1109  return cpl_error_get_code();
1110 }