UVES Pipeline Reference Manual  5.4.0
uves_baryvel.c
1 /* *
2  * This file is part of the ESO UVES 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: 2010-09-24 09:32:02 $
23  * $Revision: 1.10 $
24  * $Name: not supported by cvs2svn $
25  * $Log: not supported by cvs2svn $
26  * Revision 1.8 2007/06/06 08:17:33 amodigli
27  * replace tab with 4 spaces
28  *
29  * Revision 1.7 2007/04/24 12:50:29 jmlarsen
30  * Replaced cpl_propertylist -> uves_propertylist which is much faster
31  *
32  * Revision 1.6 2007/03/15 12:33:16 jmlarsen
33  * Removed redundant explicit array size
34  *
35  * Revision 1.5 2006/11/06 15:19:41 jmlarsen
36  * Removed unused include directives
37  *
38  * Revision 1.4 2006/10/05 06:44:58 jmlarsen
39  * Declared functions static
40  *
41  * Revision 1.3 2006/10/04 10:59:04 jmlarsen
42  * Implemented QC.VRAD parameters
43  *
44  * Revision 1.2 2006/10/04 09:55:44 jmlarsen
45  * Implemented
46  *
47  * Revision 1.4 2006/08/17 13:56:52 jmlarsen
48  * Reduced max line length
49  *
50  * Revision 1.3 2005/12/19 16:17:56 jmlarsen
51  * Replaced bool -> int
52  *
53  */
54 
55 #ifdef HAVE_CONFIG_H
56 # include <config.h>
57 #endif
58 
59 /*----------------------------------------------------------------------------*/
72 /*----------------------------------------------------------------------------*/
75 /*-----------------------------------------------------------------------------
76  Includes
77  -----------------------------------------------------------------------------*/
78 
79 #include <uves_baryvel.h>
80 
81 #include <uves_pfits.h>
82 #include <uves_utils.h>
83 #include <uves_error.h>
84 #include <uves_msg.h>
85 
86 #include <cpl.h>
87 
88 #include <math.h>
89 
90 /*-----------------------------------------------------------------------------
91  Local functions
92  -----------------------------------------------------------------------------*/
93 static void deg2dms(double in_val,
94  double *degs,
95  double *minutes,
96  double *seconds);
97 
98 static void deg2hms(double in_val,
99  double *hour,
100  double *min,
101  double *sec);
102 
103 static void compxy(double inputr[19], char inputc[4],
104  double outputr[4],
105  double utr, double mod_juldat);
106 
107 static void barvel(double DJE, double DEQ,
108  double DVELH[4], double DVELB[4]);
109 
110 
111 /*----------------------------------------------------------------------------*/
118 /*----------------------------------------------------------------------------*/
119 void
120 uves_baryvel(const uves_propertylist *raw_header,
121  double *bary_corr,
122  double *helio_corr)
123 {
124 
125  double outputr[4];
126 
127 //inputc(1:3) = "+++"
128  char inputc[] = "X+++"; /* 0th index not used */
129 
130 //define/local rneg/r/1/1 1.0
131  double rneg = 1.0;
132 
133 // write/keyw inputr/r/1/18 0.0 all
134  double inputr[19]; /* Do not use the zeroth element */
135 
136 
137 /*
138  qc_ra = m$value({p1},O_POS(1))
139  qc_dec = m$value({p1},O_POS(2))
140  qc_geolat = m$value({p1},{h_geolat})
141  qc_geolon = m$value({p1},{h_geolon})
142  qc_obs_time = m$value({p1},O_TIME(7)) !using an image as input it take the
143  !date from the descriptor O_TIME(1,2,3)
144  !and the UT from O_TIME(5)
145 */
146  double qc_ra;
147  double qc_dec;
148  double qc_geolat;
149  double qc_geolon;
150 
151  double utr;
152  double mod_juldat;
153 
154  double ra_hour, ra_min, ra_sec;
155  double dec_deg, dec_min, dec_sec;
156  double lat_deg, lat_min, lat_sec;
157  double lon_deg, lon_min, lon_sec;
158 
159  check( qc_ra = uves_pfits_get_ra(raw_header), /* in degrees */
160  "Error getting object right ascension");
161  check( qc_dec = uves_pfits_get_dec(raw_header),
162  "Error getting object declination");
163 
164  check( qc_geolat = uves_pfits_get_geolat(raw_header),
165  "Error getting telescope latitude");
166  check( qc_geolon = uves_pfits_get_geolon(raw_header),
167  "Error getting telescope longitude");
168 
169  /* double qc_obs_time = uves_pfits_get_exptime(raw_header); Not used! */
170 
171  check( utr = uves_pfits_get_utc(raw_header),
172  "Error reading UTC");
173  check( mod_juldat = uves_pfits_get_mjdobs(raw_header),
174  "Error julian date");
175 
176  deg2hms(qc_ra, &ra_hour, &ra_min, &ra_sec);
177  deg2dms(qc_dec, &dec_deg, &dec_min, &dec_sec);
178  deg2dms(qc_geolat, &lat_deg, &lat_min, &lat_sec);
179  deg2dms(qc_geolon, &lon_deg, &lon_min, &lon_sec);
180 
181 // inputr(1) = m$value({p1},o_time(1))
182 // inputr(2) = m$value({p1},o_time(2))
183 // inputr(3) = m$value({p1},o_time(3))
184 // inputr(4) = m$value({p1},o_time(5)) !UT in real hours
185 // inputr[1] = year; not needed, pass mjd instead
186 // inputr[2] = month;
187 // inputr[3] = day;
188 // inputr[4] = ut_hour; not needed, pass ut instead
189 // inputr[5] = ut_min;
190 // inputr[6] = ut_sec;
191 
192 // write/keyw inputr/r/7/3 {p4}
193  inputr[7] = lon_deg;
194  inputr[8] = lon_min;
195  inputr[9] = lon_sec;
196 
197  //rneg = (inputr(7)*3600.)+(inputr(8)*60.)+inputr(9)
198  rneg = (inputr[7]*3600.)+(inputr[8]*60.)+inputr[9];
199  //inputc(1:1) = p4(1:1)
200  inputc[1] = (lon_deg >= 0) ? '+' : '-';
201  //if rneg .lt. 0.0 inputc(1:1) = "-"
202  if (rneg < 0) inputc[1] = '-';
203 
204 // write/keyw inputr/r/10/3 {p5},0,0
205  inputr[10] = lat_deg;
206  inputr[11] = lat_min;
207  inputr[12] = lat_sec;
208 
209 // rneg = (inputr(10)*3600.)+(inputr(11)*60.)+inputr(12)
210  rneg = (inputr[10]*3600.)+(inputr[11]*60.)+inputr[12];
211 // inputc(2:2) = p5(1:1)
212  inputc[2] = (lat_deg >= 0) ? '+' : '-';
213 // if rneg .lt. 0.0 inputc(2:2) = "-"
214  if (rneg < 0) inputc[2] = '-';
215 
216 // write/keyw inputr/r/13/3 {p2},0,0
217  inputr[13] = ra_hour;
218  inputr[14] = ra_min;
219  inputr[15] = ra_sec;
220 
221 // write/keyw inputr/r/16/3 {p3},0,0
222  inputr[16] = dec_deg;
223  inputr[17] = dec_min;
224  inputr[18] = dec_sec;
225 
226 // inputc(3:3) = p3(1:1)
227  inputc[3] = (dec_deg >= 0) ? '+' : '-';
228 // rneg = (inputr(16)*3600.)+(inputr(17)*60.)+inputr(18)
229  rneg = (inputr[16]*3600.)+(inputr[17]*60.)+inputr[18];
230 // if rneg .lt. 0.0 inputc(3:3) = "-"
231  if (rneg < 0) inputc[3] = '-';
232 
233 
234 //C INPUTR/R/1/3 date: year,month,day
235 //C INPUTR/R/4/3 universal time: hour,min,sec
236 //C INPUTR/R/7/3 EAST longitude of observatory: degree,min,sec !! NOTE
237 //C INPUTR/R/10/3 latitude of observatory: degree,min,sec
238 //C INPUTR/R/13/3 right ascension: hour,min,sec
239 //C INPUTR/R/16/3 declination: degree,min,sec
240 
241  //write/keyw action BA !indicate barycorr stuff
242  //run MID_EXE:COMPXY !compute the corrections
243 
244  compxy(inputr, inputc, outputr, utr, mod_juldat);
245 
246 // set/format f14.6,g24.12
247 // uves_msg_debug(" Barycentric correction time: {outputd(1)} day");
248 // uves_msg_debug(" Heliocentric correction time: {outputd(2)} day");
249 // uves_msg_debug(" ");
250  uves_msg_debug(" Total barycentric RV correction: %f km/s", outputr[1]);
251  uves_msg_debug(" Total heliocentric RV correction: %f km/s", outputr[2]);
252  uves_msg_debug(" (incl. diurnal RV correction of %f km/s)", outputr[3]);
253 // uves_msg_debug(" ");
254 // uves_msg_debug("Descriptor O_TIME of image {p1} used for date and UT.");
255 
256  *bary_corr = outputr[1];
257  *helio_corr = outputr[2];
258 
259  cleanup:
260  return;
261 }
262 
263 
264 /*----------------------------------------------------------------------------*/
286 /*----------------------------------------------------------------------------*/
287 static void
288 compxy(double inputr[19], char inputc[4],
289  double outputr[4],
290  double utr, double mod_juldat)
291 {
292 
293 // INTEGER IAV,STAT,KUN(1),KNUL,N
294 // INTEGER MADRID
295 //
296 // DOUBLE PRECISION UTR,STR,T0,DL,THETA0,PE,ST0HG,STG,GAST,R1
297  double STR;
298 
299 // double utr Not used. Use FITS header value instead
300  double t0, dl, theta0, pe, st0hg, stg;
301 // DOUBLE PRECISION JD,JD0H,JD00,ZERO
302  double jd, jd0h;
303 // DOUBLE PRECISION DCORB(3),DCORH(3),DVELB(3),DVELH(3)
304  double dvelb[4], dvelh[4];
305 // DOUBLE PRECISION ALP,BCT,BEOV,BERV,DEL,EDV
306  double alp, del, beov, berv, EDV;
307 // DOUBLE PRECISION HAR,HCT,HEOV,HERV,PHI,PI
308  double HAR, phi, heov, herv;
309 // DOUBLE PRECISION EQX0,EQX1
310 // DOUBLE PRECISION A0R,A1R,D0R,D1R
311 // DOUBLE PRECISION DSMALL,DTEMP(3)
312 //
313 // REAL DATE0(3),DATE1(3),DATE00(3),A0(3),A1(3),D0(3),D1(3)
314 // REAL DATE(3),UT(3),OLONG(3),ST(3)
315 // double ut[4];
316 // REAL OLAT(3),ALPHA(3),DELTA(3)
317 // REAL RBUF(20)
318  double *rbuf;
319 //
320 // CHARACTER ACTIO*2,SIGNS*3,INPSGN*3
321  char inpsgn[4];
322 //
323 // COMMON /VMR/MADRID(1)
324 //
325 // DATA PI /3.1415926535897928D0/
326 // DATA DSMALL /1.D-38/
327 
328 
329  double *olong, *olat, *alpha, *delta;
330 
331 //1000 SIGNS = '+++'
332  char signs[] = "+++";
333 
334 // CALL STKRDR('INPUTR',1,20,IAV,RBUF,KUN,KNUL,STAT)
335  rbuf = inputr;
336 // CALL STKRDC('INPUTC',1,1,3,IAV,INPSGN,KUN,KNUL,STAT)
337  inpsgn[1] = inputc[1];
338  inpsgn[2] = inputc[2];
339  inpsgn[3] = inputc[3];
340 
341 
342 // EQUIVALENCE (RBUF(1),DATE(1)),(RBUF(7),OLONG(1))
343 // double *date = rbuf + 1 - 1; Not used, use the explicitly passed MJD instead
344  olong = rbuf + 7 - 1;
345 // EQUIVALENCE (RBUF(10),OLAT(1)),(RBUF(13),ALPHA(1))
346  olat = rbuf + 10 - 1;
347  alpha = rbuf + 13 - 1;
348 // EQUIVALENCE (RBUF(16),DELTA(1))
349  delta = rbuf + 16 - 1;
350 
351 
352 
353 // DO 1100 N=1,3
354 // UT(N) = RBUF(N+3)
355 //1100 CONTINUE
356 // for (n = 1; n <= 3; n++)
357 // {
358 // ut[n] = rbuf[n+3];
359 // }
360 
361 // ... convert UT to real hours, calculate Julian date
362 
363 // UTR = UT(1)+UT(2)/60.D0+UT(3)/3600.D0
364 // utr = ut[1]+ut[2]/60. +ut[3]/3600.;
365 
366  /* We know this one already but convert seconds -> hours */
367  utr /= 3600;
368 
369 // CALL JULDAT(DATE,UTR,JD)
370  jd = mod_juldat + 2400000.5;
371 
372 // ... likewise convert longitude and latitude of observatory to real hours
373 // ... and degrees, respectively; take care of signs
374 // ... NOTE: east longitude is assumed for input !!
375 
376 // IF ((OLONG(1).LT.0.0) .OR. (OLONG(2).LT.0.0) .OR.
377 // + (OLONG(3).LT.0.0) .OR. (INPSGN(1:1).EQ.'-')) THEN
378  if (olong[1] < 0 || olong[2] < 0 ||
379  olong[3] < 0 || inpsgn[1] == '-') {
380 // SIGNS(1:1) = '-'
381  signs[1] = '-';
382 // OLONG(1) = ABS(OLONG(1))
383 // OLONG(2) = ABS(OLONG(2))
384 // OLONG(3) = ABS(OLONG(3))
385  olong[1] = fabs(olong[1]);
386  olong[2] = fabs(olong[2]);
387  olong[3] = fabs(olong[3]);
388 // ENDIF
389  }
390 
391 // DL = OLONG(1)+OLONG(2)/60.D0+OLONG(3)/3600.D0
392  dl = olong[1]+olong[2]/60. +olong[3]/3600.;
393 
394 // IF (SIGNS(1:1).EQ.'-') DL = -DL ! negative longitude
395  if (signs[1] == '-') dl = -dl;
396 
397 // DL = -DL*24.D0/360.D0 ! convert back to west longitude
398  dl = -dl*24. /360.;
399 
400 // IF ((OLAT(1).LT.0.0) .OR. (OLAT(2).LT.0.0) .OR.
401 // + (OLAT(3).LT.0.0) .OR. (INPSGN(2:2).EQ.'-')) THEN
402  if (olat[1] < 0 || olat[2] < 0 ||
403  olat[3] < 0 || inpsgn[2] == '-') {
404 // SIGNS(2:2) = '-'
405  signs[2] = '-';
406 
407 // OLAT(1) = ABS(OLAT(1))
408 // OLAT(2) = ABS(OLAT(2))
409 // OLAT(3) = ABS(OLAT(3))
410  olat[1] = fabs(olat[1]);
411  olat[2] = fabs(olat[2]);
412  olat[3] = fabs(olat[3]);
413 // ENDIF
414  }
415 
416 // PHI = OLAT(1)+OLAT(2)/60.D0+OLAT(3)/3600.D0
417  phi = olat[1]+olat[2]/60. +olat[3]/3600.;
418 
419 // IF (SIGNS(2:2).EQ.'-') PHI = -PHI ! negative latitude
420  if (signs[2] == '-') phi = -phi;
421 
422 // PHI = PHI*PI/180.D0
423  phi = phi*M_PI/180. ;
424 
425 // ... convert right ascension and declination to real radians
426 
427 // ALP = (ALPHA(1)*3600D0+ALPHA(2)*60D0+ALPHA(3))*PI /(12.D0*3600.D0)
428  alp = (alpha[1]*3600. +alpha[2]*60. +alpha[3])*M_PI/(12. *3600. );
429 
430 // IF ((DELTA(1).LT.0.0) .OR. (DELTA(2).LT.0.0) .OR.
431 // + (DELTA(3).LT.0.0) .OR. (INPSGN(3:3).EQ.'-')) THEN
432  if (delta[1] < 0 || delta[2] < 0 ||
433  delta[3] < 0 || inpsgn[3] == '-') {
434 // SIGNS(3:3) = '-'
435  signs[3] = '-';
436 // DELTA(1) = ABS(DELTA(1))
437 // DELTA(2) = ABS(DELTA(2))
438 // DELTA(3) = ABS(DELTA(3))
439  delta[1] = fabs(delta[1]);
440  delta[2] = fabs(delta[2]);
441  delta[3] = fabs(delta[3]);
442 // ENDIF
443  }
444 
445 // DEL = (DELTA(1)*3600.D0 + DELTA(2)*60.D0 + DELTA(3))
446 // + * PI/(3600.D0*180.D0)
447  del = (delta[1]*3600.0 + delta[2]*60. + delta[3])
448  * M_PI/(3600. *180. );
449 
450 
451 // IF (SIGNS(3:3).EQ.'-') DEL = -DEL ! negative declination
452  if (signs[3] == '-') del = - del;
453 
454 // ... calculate earth's orbital velocity in rectangular coordinates X,Y,Z
455 // ... for both heliocentric and barycentric frames (DVELH, DVELB)
456 // ... Note that setting the second argument of BARVEL to zero as done below
457 // ... means that the input coordinates will not be corrected for precession.
458 
459 // CALL BARVEL(JD,0.0D0,DVELH,DVELB)
460  barvel(jd, 0.0, dvelh, dvelb);
461 
462 // ... with the rectangular velocity components known, the respective projections
463 // ... HEOV and BEOV on a given line of sight (ALP,DEL) can be determined:
464 
465 // ... REFERENCE: THE ASTRONOMICAL ALMANAC 1982 PAGE:B17
466 
467 // BEOV=DVELB(1)*DCOS(ALP)*DCOS(DEL)+
468 // 1 DVELB(2)*DSIN(ALP)*DCOS(DEL)+
469 // 2 DVELB(3)*DSIN(DEL)
470  beov =
471  dvelb[1]*cos(alp)*cos(del)+
472  dvelb[2]*sin(alp)*cos(del)+
473  dvelb[3]*sin(del);
474 
475 // HEOV=DVELH(1)*DCOS(ALP)*DCOS(DEL)+
476 // 1 DVELH(2)*DSIN(ALP)*DCOS(DEL)+
477 // 2 DVELH(3)*DSIN(DEL)
478  heov =
479  dvelh[1]*cos(alp)*cos(del)+
480  dvelh[2]*sin(alp)*cos(del)+
481  dvelh[3]*sin(del);
482 
483 
484 // ... For determination also of the contribution due to the diurnal rotation of
485 // ... the earth (EDV), the hour angle (HAR) is needed at which the observation
486 // ... was made which requires conversion of UT to sidereal time (ST).
487 
488 // ... Therefore, first compute ST at 0 hours UT (ST0HG)
489 
490 // ... REFERENCE : MEEUS J.,1980,ASTRONOMICAL FORMULAE FOR CALCULATORS
491 
492 // CALL JULDAT(DATE,ZERO,JD0H)
493  jd0h = jd - (utr/24.0);
494 
495 // T0=(JD0H-2415020.D0)/36525.D0
496  t0 = (jd0h-2415020. )/36525. ;
497 
498 // THETA0=0.276919398D0+100.0021359D0*T0+0.000001075D0*T0*T0
499  theta0 = 0.276919398 +100.0021359 *t0+0.000001075 *t0*t0 ;
500 
501 // PE=DINT(THETA0)
502  pe = (int) theta0;
503 
504 // THETA0=THETA0-PE
505  theta0 = theta0 - pe;
506 
507 // ST0HG=THETA0*24.D0
508  st0hg = theta0*24. ;
509 
510 // ... now do the conversion UT -> ST (MEAN SIDEREAL TIME)
511 
512 // ... REFERENCE : THE ASTRONOMICAL ALMANAC 1983, P B7
513 // ... IN 1983: 1 MEAN SOLAR DAY = 1.00273790931 MEAN SIDEREAL DAYS
514 // ... ST WITHOUT EQUATION OF EQUINOXES CORRECTION => ACCURACY +/- 1 SEC
515 //
516 // STG=ST0HG+UTR*1.00273790931D0
517  stg = st0hg+utr*1.00273790931 ;
518 
519 // IF (STG.LT.DL) STG=STG+24.D0
520  if (stg < dl) stg = stg +24. ;
521 
522 // STR=STG-DL
523  STR = stg-dl;
524 
525 // IF (STR.GE.24.D0) STR=STR-24.D0
526  if (STR >= 24. ) STR = STR-24. ;
527 
528 // STR = STR*PI/12.D0 ! ST in radians
529  STR = STR*M_PI/12. ;
530 
531 // HAR=STR-ALP ! hour angle of observation
532  HAR = STR-alp;
533 
534 // EDV=-0.4654D0*DSIN(HAR)*DCOS(DEL)*DCOS(PHI)
535  EDV = -0.4654 * sin(HAR)* cos(del)* cos(phi);
536 
537 // ... the total correction (in km/s) is the sum of orbital and diurnal components
538 
539 // HERV=HEOV+EDV
540  herv=heov+EDV;
541 // BERV=BEOV+EDV
542  berv=beov+EDV;
543 
544  /* The following is not needed. Do not translate */
545 
546 #if 0
547 // ... Calculation of the barycentric and heliocentric correction times
548 // ... (BCT and HCT) requires knowledge of the earth's position in its
549 // ... orbit. Subroutine BARCOR returns the rectangular barycentric (DCORB)
550 // ... and heliocentric (DCORH) coordinates.
551 
552 // CALL BARCOR(DCORH,DCORB)
553 
554 // ... from this, the correction times (in days) can be determined:
555 // ... (REFERENCE: THE ASTRONOMICAL ALMANAC 1982 PAGE:B16)
556 
557 // BCT=+0.0057756D0*(DCORB(1)*DCOS(ALP)*DCOS(DEL)+
558 // 1 DCORB(2)*DSIN(ALP)*DCOS(DEL)+
559 // 2 DCORB(3)* DSIN(DEL))
560 // HCT=+0.0057756D0*(DCORH(1)*DCOS(ALP)*DCOS(DEL)+
561 // 1 DCORH(2)*DSIN(ALP)*DCOS(DEL)+
562 // 2 DCORH(3)* DSIN(DEL))
563 
564 //... write results to keywords
565 
566 // CALL STKWRD('OUTPUTD',BCT,1,1,KUN,STAT) ! barycentric correction time
567 // CALL STKWRD('OUTPUTD',HCT,2,1,KUN,STAT) ! heliocentric correction time
568 #endif
569 
570 
571 // RBUF(1) = BERV ! barocentric RV correction
572 // RBUF(2) = HERV ! heliocentric RV correction
573 // ... (note that EDV is already contained in both BERV and HERV)
574 // RBUF(3) = EDV ! diurnal RV correction
575  rbuf[1] = berv;
576  rbuf[2] = herv;
577  rbuf[3] = EDV;
578 
579 // CALL STKWRR('OUTPUTR',RBUF,1,3,KUN,STAT)
580  outputr[1] = rbuf[1];
581  outputr[2] = rbuf[2];
582  outputr[3] = rbuf[3];
583 // GOTO 9000
584  return;
585 }
586 
587 /* @cond Convert FORTRAN indexing -> C indexing */
588 #define DCFEL(x,y) dcfel[y][x]
589 #define DCFEPS(x,y) dcfeps[y][x]
590 #define CCSEL(x,y) ccsel[y][x]
591 #define DCARGS(x,y) dcargs[y][x]
592 #define CCAMPS(x,y) ccamps[y][x]
593 #define CCSEC(x,y) ccsec[y][x]
594 #define DCARGM(x,y) dcargm[y][x]
595 #define CCAMPM(x,y) ccampm[y][x]
596 #define DCEPS(x) dceps[x]
597 #define FORBEL(x) forbel[x]
598 #define SORBEL(x) sorbel[x]
599 #define SN(x) sn[x]
600 #define SINLP(x) sinlp[x]
601 #define COSLP(x) coslp[x]
602 #define CCPAMV(x) ccpamv[x]
603 /* @endcond */
604 /*----------------------------------------------------------------------------*/
617 /*----------------------------------------------------------------------------*/
618 
619 // SUBROUTINE BARVEL(DJE,DEQ,DVELH,DVELB)
620 
621 static
622 void barvel(double DJE, double DEQ,
623  double DVELH[4], double DVELB[4])
624 {
625 // DOUBLE PRECISION DJE,DEQ,DVELH(3),DVELB(3),SN(4)
626  double sn[5];
627 // DOUBLE PRECISION DT,DTL,DCT0,DCJUL,DTSQ,DLOCAL,DC2PI,CC2PI
628  double DT,DTL,DTSQ,DLOCAL;
629 // DOUBLE PRECISION DRD,DRLD,DCSLD,DC1
630  double DRD,DRLD;
631 // DOUBLE PRECISION DXBD,DYBD,DZBD,DZHD,DXHD,DYHD
632  double DXBD,DYBD,DZBD,DZHD,DXHD,DYHD;
633 // DOUBLE PRECISION DYAHD,DZAHD,DYABD,DZABD
634  double DYAHD,DZAHD,DYABD,DZABD;
635 // DOUBLE PRECISION DML,DEPS,PHI,PHID,PSID,DPARAM,PARAM
636  double DML,DEPS,PHI,PHID,PSID,DPARAM,PARAM;
637 // DOUBLE PRECISION CCFDI,CCKM,CCMLD,PLON,POMG,PECC
638  double PLON,POMG,PECC;
639 // DOUBLE PRECISION PERTL,PERTLD,PERTRD,PERTP,PERTR,PERTPD
640  double PERTL,PERTLD,PERTRD,PERTP,PERTR,PERTPD;
641 // DOUBLE PRECISION SINA,CCSGD,DC1MME,TL
642  double SINA,TL;
643 // DOUBLE PRECISION CCSEC3,COSA,ESQ
644  double COSA,ESQ;
645 // DOUBLE PRECISION DCFEL(3,8),DCEPS(3),CCSEL(3,17),DCARGS(2,15)
646 // DOUBLE PRECISION CCAMPS(5,15),CCSEC(3,4),DCARGM(2,3)
647 // DOUBLE PRECISION CCAMPM(4,3),CCPAMV(4)
648 // DOUBLE PRECISION A,B,E,F,G,SINF,COSF,T,TSQ,TWOE,TWOG
649  double A,B,F,SINF,COSF,T,TSQ,TWOE,TWOG;
650 //C
651 // DOUBLE PRECISION DPREMA(3,3),DPSI,D1PDRO,DSINLS
652  double DPSI,D1PDRO,DSINLS;
653 // DOUBLE PRECISION DCOSLS,DSINEP,DCOSEP
654  double DCOSLS,DSINEP,DCOSEP;
655 // DOUBLE PRECISION FORBEL(7),SORBEL(17),SINLP(4),COSLP(4)
656  double forbel[8], sorbel[18], sinlp[5], coslp[5];
657 // DOUBLE PRECISION SINLM,COSLM,SIGMA
658  double SINLM,COSLM,SIGMA;
659 //C
660 // INTEGER IDEQ,K,N
661  int IDEQ,K,N;
662 //C
663 // COMMON /BARXYZ/ DPREMA,DPSI,D1PDRO,DSINLS,DCOSLS,
664 // + DSINEP,DCOSEP,FORBEL,SORBEL,SINLP,
665 // + COSLP,SINLM,COSLM,SIGMA,IDEQ
666 
667 // EQUIVALENCE (SORBEL(1),E),(FORBEL(1),G)
668  double *E = sorbel + 1 - 1;
669  double *G = forbel + 1 - 1;
670 //C
671 // DATA DC2PI/6.2831853071796D0/,CC2PI/6.283185/,
672  double DC2PI = 6.2831853071796E0;
673  double CC2PI = 6.283185; /* ??? */
674 
675 // *DC1/1.0D0/,DCT0/2415020.0D0/,DCJUL/36525.0D0/
676  double DC1 = 1.0;
677  double DCT0 = 2415020.0E0;
678  double DCJUL = 36525.0E0;
679 //C
680 // DATA DCFEL/ 1.7400353D+00, 6.2833195099091D+02, 5.2796D-06,
681 // * 6.2565836D+00, 6.2830194572674D+02,-2.6180D-06,
682 // * 4.7199666D+00, 8.3997091449254D+03,-1.9780D-05,
683 // * 1.9636505D-01, 8.4334662911720D+03,-5.6044D-05,
684 // * 4.1547339D+00, 5.2993466764997D+01, 5.8845D-06,
685 // * 4.6524223D+00, 2.1354275911213D+01, 5.6797D-06,
686 // * 4.2620486D+00, 7.5025342197656D+00, 5.5317D-06,
687 // * 1.4740694D+00, 3.8377331909193D+00, 5.6093D-06/
688 
689  double dcfel[][4] = { {0, 0, 0, 0},
690  {0, 1.7400353E+00, 6.2833195099091E+02, 5.2796E-06},
691  {0, 6.2565836E+00, 6.2830194572674E+02,-2.6180E-06},
692  {0, 4.7199666E+00, 8.3997091449254E+03,-1.9780E-05},
693  {0, 1.9636505E-01, 8.4334662911720E+03,-5.6044E-05},
694  {0, 4.1547339E+00, 5.2993466764997E+01, 5.8845E-06},
695  {0, 4.6524223E+00, 2.1354275911213E+01, 5.6797E-06},
696  {0, 4.2620486E+00, 7.5025342197656E+00, 5.5317E-06},
697  {0, 1.4740694E+00, 3.8377331909193E+00, 5.6093E-06} };
698 
699 //C
700 // DATA DCEPS/ 4.093198D-01,-2.271110D-04,-2.860401D-08/
701  double dceps[4] = {0, 4.093198E-01,-2.271110E-04,-2.860401E-08};
702 
703 //C
704 // DATA CCSEL/ 1.675104D-02,-4.179579D-05,-1.260516D-07,
705 // * 2.220221D-01, 2.809917D-02, 1.852532D-05,
706 // * 1.589963D+00, 3.418075D-02, 1.430200D-05,
707 // * 2.994089D+00, 2.590824D-02, 4.155840D-06,
708 // * 8.155457D-01, 2.486352D-02, 6.836840D-06,
709 // * 1.735614D+00, 1.763719D-02, 6.370440D-06,
710 // * 1.968564D+00, 1.524020D-02,-2.517152D-06,
711 // * 1.282417D+00, 8.703393D-03, 2.289292D-05,
712 // * 2.280820D+00, 1.918010D-02, 4.484520D-06,
713 // * 4.833473D-02, 1.641773D-04,-4.654200D-07,
714 // * 5.589232D-02,-3.455092D-04,-7.388560D-07,
715 // * 4.634443D-02,-2.658234D-05, 7.757000D-08,
716 // * 8.997041D-03, 6.329728D-06,-1.939256D-09,
717 // * 2.284178D-02,-9.941590D-05, 6.787400D-08,
718 // * 4.350267D-02,-6.839749D-05,-2.714956D-07,
719 // * 1.348204D-02, 1.091504D-05, 6.903760D-07,
720 // * 3.106570D-02,-1.665665D-04,-1.590188D-07/
721 
722  double ccsel[][4] = { {0, 0, 0, 0},
723  {0, 1.675104E-02, -4.179579E-05, -1.260516E-07},
724  {0, 2.220221E-01, 2.809917E-02, 1.852532E-05},
725  {0, 1.589963E+00, 3.418075E-02, 1.430200E-05},
726  {0, 2.994089E+00, 2.590824E-02, 4.155840E-06},
727  {0, 8.155457E-01, 2.486352E-02, 6.836840E-06},
728  {0, 1.735614E+00, 1.763719E-02, 6.370440E-06},
729  {0, 1.968564E+00, 1.524020E-02, -2.517152E-06},
730  {0, 1.282417E+00, 8.703393E-03, 2.289292E-05},
731  {0, 2.280820E+00, 1.918010E-02, 4.484520E-06},
732  {0, 4.833473E-02, 1.641773E-04, -4.654200E-07},
733  {0, 5.589232E-02, -3.455092E-04, -7.388560E-07},
734  {0, 4.634443E-02, -2.658234E-05, 7.757000E-08},
735  {0, 8.997041E-03, 6.329728E-06, -1.939256E-09},
736  {0, 2.284178E-02, -9.941590E-05, 6.787400E-08},
737  {0, 4.350267E-02, -6.839749E-05, -2.714956E-07},
738  {0, 1.348204E-02, 1.091504E-05, 6.903760E-07},
739  {0, 3.106570E-02, -1.665665E-04, -1.590188E-07} };
740 
741 
742 
743 // DATA DCARGS/ 5.0974222D+00,-7.8604195454652D+02,
744 // * 3.9584962D+00,-5.7533848094674D+02,
745 // * 1.6338070D+00,-1.1506769618935D+03,
746 // * 2.5487111D+00,-3.9302097727326D+02,
747 // * 4.9255514D+00,-5.8849265665348D+02,
748 // * 1.3363463D+00,-5.5076098609303D+02,
749 // * 1.6072053D+00,-5.2237501616674D+02,
750 // * 1.3629480D+00,-1.1790629318198D+03,
751 // * 5.5657014D+00,-1.0977134971135D+03,
752 // * 5.0708205D+00,-1.5774000881978D+02,
753 // * 3.9318944D+00, 5.2963464780000D+01,
754 // * 4.8989497D+00, 3.9809289073258D+01,
755 // * 1.3097446D+00, 7.7540959633708D+01,
756 // * 3.5147141D+00, 7.9618578146517D+01,
757 // * 3.5413158D+00,-5.4868336758022D+02/
758 
759  double dcargs[][3] = { {0, 0, 0},
760  {0, 5.0974222E+00, -7.8604195454652E+02},
761  {0, 3.9584962E+00, -5.7533848094674E+02},
762  {0, 1.6338070E+00, -1.1506769618935E+03},
763  {0, 2.5487111E+00, -3.9302097727326E+02},
764  {0, 4.9255514E+00, -5.8849265665348E+02},
765  {0, 1.3363463E+00, -5.5076098609303E+02},
766  {0, 1.6072053E+00, -5.2237501616674E+02},
767  {0, 1.3629480E+00, -1.1790629318198E+03},
768  {0, 5.5657014E+00, -1.0977134971135E+03},
769  {0, 5.0708205E+00, -1.5774000881978E+02},
770  {0, 3.9318944E+00, 5.2963464780000E+01},
771  {0, 4.8989497E+00, 3.9809289073258E+01},
772  {0, 1.3097446E+00, 7.7540959633708E+01},
773  {0, 3.5147141E+00, 7.9618578146517E+01},
774  {0, 3.5413158E+00, -5.4868336758022E+02} };
775 
776 // DATA CCAMPS/
777 // *-2.279594D-5, 1.407414D-5, 8.273188D-6, 1.340565D-5,-2.490817D-7,
778 // *-3.494537D-5, 2.860401D-7, 1.289448D-7, 1.627237D-5,-1.823138D-7,
779 // * 6.593466D-7, 1.322572D-5, 9.258695D-6,-4.674248D-7,-3.646275D-7,
780 // * 1.140767D-5,-2.049792D-5,-4.747930D-6,-2.638763D-6,-1.245408D-7,
781 // * 9.516893D-6,-2.748894D-6,-1.319381D-6,-4.549908D-6,-1.864821D-7,
782 // * 7.310990D-6,-1.924710D-6,-8.772849D-7,-3.334143D-6,-1.745256D-7,
783 // *-2.603449D-6, 7.359472D-6, 3.168357D-6, 1.119056D-6,-1.655307D-7,
784 // *-3.228859D-6, 1.308997D-7, 1.013137D-7, 2.403899D-6,-3.736225D-7,
785 // * 3.442177D-7, 2.671323D-6, 1.832858D-6,-2.394688D-7,-3.478444D-7,
786 // * 8.702406D-6,-8.421214D-6,-1.372341D-6,-1.455234D-6,-4.998479D-8,
787 // *-1.488378D-6,-1.251789D-5, 5.226868D-7,-2.049301D-7, 0.0D0,
788 // *-8.043059D-6,-2.991300D-6, 1.473654D-7,-3.154542D-7, 0.0D0,
789 // * 3.699128D-6,-3.316126D-6, 2.901257D-7, 3.407826D-7, 0.0D0,
790 // * 2.550120D-6,-1.241123D-6, 9.901116D-8, 2.210482D-7, 0.0D0,
791 // *-6.351059D-7, 2.341650D-6, 1.061492D-6, 2.878231D-7, 0.0D0/
792 
793  double ccamps[][6] =
794  {{0, 0, 0, 0, 0, 0},
795  {0, -2.279594E-5, 1.407414E-5, 8.273188E-6, 1.340565E-5, -2.490817E-7},
796  {0, -3.494537E-5, 2.860401E-7, 1.289448E-7, 1.627237E-5, -1.823138E-7},
797  {0, 6.593466E-7, 1.322572E-5, 9.258695E-6, -4.674248E-7, -3.646275E-7},
798  {0, 1.140767E-5, -2.049792E-5, -4.747930E-6, -2.638763E-6, -1.245408E-7},
799  {0, 9.516893E-6, -2.748894E-6, -1.319381E-6, -4.549908E-6, -1.864821E-7},
800  {0, 7.310990E-6, -1.924710E-6, -8.772849E-7, -3.334143E-6, -1.745256E-7},
801  {0, -2.603449E-6, 7.359472E-6, 3.168357E-6, 1.119056E-6, -1.655307E-7},
802  {0, -3.228859E-6, 1.308997E-7, 1.013137E-7, 2.403899E-6, -3.736225E-7},
803  {0, 3.442177E-7, 2.671323E-6, 1.832858E-6, -2.394688E-7, -3.478444E-7},
804  {0, 8.702406E-6, -8.421214E-6, -1.372341E-6, -1.455234E-6, -4.998479E-8},
805  {0, -1.488378E-6, -1.251789E-5, 5.226868E-7, -2.049301E-7, 0.0E0},
806  {0, -8.043059E-6, -2.991300E-6, 1.473654E-7, -3.154542E-7, 0.0E0},
807  {0, 3.699128E-6, -3.316126E-6, 2.901257E-7, 3.407826E-7, 0.0E0},
808  {0, 2.550120E-6, -1.241123E-6, 9.901116E-8, 2.210482E-7, 0.0E0},
809  {0, -6.351059E-7, 2.341650E-6, 1.061492E-6, 2.878231E-7, 0.0E0}};
810 
811 
812 // DATA CCSEC3/-7.757020D-08/
813  double CCSEC3 = -7.757020E-08;
814 //C
815 // DATA CCSEC/ 1.289600D-06, 5.550147D-01, 2.076942D+00,
816 // * 3.102810D-05, 4.035027D+00, 3.525565D-01,
817 // * 9.124190D-06, 9.990265D-01, 2.622706D+00,
818 // * 9.793240D-07, 5.508259D+00, 1.559103D+01/
819 
820  double ccsec[][4] = { {0, 0, 0, 0},
821  {0, 1.289600E-06, 5.550147E-01, 2.076942E+00},
822  {0, 3.102810E-05, 4.035027E+00, 3.525565E-01},
823  {0, 9.124190E-06, 9.990265E-01, 2.622706E+00},
824  {0, 9.793240E-07, 5.508259E+00, 1.559103E+01}};
825 
826 //C
827 // DATA DCSLD/ 1.990987D-07/, CCSGD/ 1.990969D-07/
828  double DCSLD = 1.990987E-07, CCSGD = 1.990969E-07;
829 //C
830 // DATA CCKM/3.122140D-05/, CCMLD/2.661699D-06/, CCFDI/2.399485D-07/
831  double CCKM = 3.122140E-05, CCMLD = 2.661699E-06, CCFDI = 2.399485E-07;
832 //C
833 // DATA DCARGM/ 5.1679830D+00, 8.3286911095275D+03,
834 // * 5.4913150D+00,-7.2140632838100D+03,
835 // * 5.9598530D+00, 1.5542754389685D+04/
836 
837  double dcargm[][3] = {{0, 0, 0},
838  {0, 5.1679830E+00, 8.3286911095275E+03},
839  {0, 5.4913150E+00, -7.2140632838100E+03},
840  {0, 5.9598530E+00, 1.5542754389685E+04}};
841 //C
842 // DATA CCAMPM/
843 // * 1.097594D-01, 2.896773D-07, 5.450474D-02, 1.438491D-07,
844 // * -2.223581D-02, 5.083103D-08, 1.002548D-02,-2.291823D-08,
845 // * 1.148966D-02, 5.658888D-08, 8.249439D-03, 4.063015D-08/
846 
847  double ccampm[][5] = {{0, 0, 0, 0, 0},
848  {0, 1.097594E-01, 2.896773E-07, 5.450474E-02, 1.438491E-07},
849  {0, -2.223581E-02, 5.083103E-08, 1.002548E-02, -2.291823E-08},
850  {0, 1.148966E-02, 5.658888E-08, 8.249439E-03, 4.063015E-08} };
851 
852 //C
853 // DATA CCPAMV/8.326827D-11,1.843484D-11,1.988712D-12,1.881276D-12/,
854  double ccpamv[] = {0, 8.326827E-11, 1.843484E-11, 1.988712E-12, 1.881276E-12};
855 // * DC1MME/0.99999696D0/
856  double DC1MME = 0.99999696E0;
857 //C
858 
859 // IDEQ=DEQ
860  IDEQ=DEQ;
861 
862 // DT=(DJE-DCT0)/DCJUL
863  DT=(DJE-DCT0)/DCJUL;
864 
865 // T=DT
866  T=DT;
867 
868 // DTSQ=DT*DT
869  DTSQ=DT*DT;
870 
871 // TSQ=DTSQ
872  TSQ=DTSQ;
873 
874  DML = 0; /* Suppress warning */
875 // DO 100, K=1,8
876  for (K = 1; K <= 8; K++) {
877 
878 // DLOCAL=DMOD(DCFEL(1,K)+DT*DCFEL(2,K)+DTSQ*DCFEL(3,K),DC2PI)
879  DLOCAL=fmod(DCFEL(1,K)+DT*DCFEL(2,K)+DTSQ*DCFEL(3,K),DC2PI);
880 
881 // IF (K.EQ.1) DML=DLOCAL
882  if (K == 1) DML=DLOCAL;
883 
884 // IF (K.NE.1) FORBEL(K-1)=DLOCAL
885  if (K != 1) FORBEL(K-1)=DLOCAL;
886 // 100 CONTINUE
887  }
888 
889 // DEPS=DMOD(DCEPS(1)+DT*DCEPS(2)+DTSQ*DCEPS(3), DC2PI)
890  DEPS=fmod(DCEPS(1)+DT*DCEPS(2)+DTSQ*DCEPS(3), DC2PI);
891 
892 // DO 200, K=1,17
893  for (K = 1; K <= 17; K++) {
894 
895 // SORBEL(K)=DMOD(CCSEL(1,K)+T*CCSEL(2,K)+TSQ*CCSEL(3,K),CC2PI)
896  SORBEL(K)=fmod(CCSEL(1,K)+T*CCSEL(2,K)+TSQ*CCSEL(3,K),CC2PI);
897 
898 // 200 CONTINUE
899  }
900 
901 // DO 300, K=1,4
902  for (K = 1; K <= 4; K++) {
903 
904 // A=DMOD(CCSEC(2,K)+T*CCSEC(3,K),CC2PI)
905  A=fmod(CCSEC(2,K)+T*CCSEC(3,K),CC2PI);
906 
907 // SN(K)=DSIN(A)
908  SN(K)=sin(A);
909 // 300 CONTINUE
910  }
911 
912 // PERTL = CCSEC(1,1) *SN(1) +CCSEC(1,2)*SN(2)
913 // * +(CCSEC(1,3)+T*CCSEC3)*SN(3) +CCSEC(1,4)*SN(4)
914 
915  PERTL = CCSEC(1,1) *SN(1) +CCSEC(1,2)*SN(2)
916  +(CCSEC(1,3)+T*CCSEC3)*SN(3) +CCSEC(1,4)*SN(4);
917 
918 // PERTLD=0.0
919 // PERTR =0.0
920 // PERTRD=0.0
921  PERTLD=0.0;
922  PERTR =0.0;
923  PERTRD=0.0;
924 
925 // DO 400, K=1,15
926  for (K = 1; K <= 15; K++) {
927 // A=DMOD(DCARGS(1,K)+DT*DCARGS(2,K), DC2PI)
928  A=fmod(DCARGS(1,K)+DT*DCARGS(2,K), DC2PI);
929 
930 // COSA=DCOS(A)
931  COSA=cos(A);
932 
933 // SINA=DSIN(A)
934  SINA=sin(A);
935 
936 // PERTL =PERTL+CCAMPS(1,K)*COSA+CCAMPS(2,K)*SINA
937  PERTL =PERTL+CCAMPS(1,K)*COSA+CCAMPS(2,K)*SINA;
938 
939 // PERTR =PERTR+CCAMPS(3,K)*COSA+CCAMPS(4,K)*SINA;
940  PERTR =PERTR+CCAMPS(3,K)*COSA+CCAMPS(4,K)*SINA;
941 
942 // IF (K.GE.11) GO TO 400
943  if (K >= 11) break;
944 
945 // PERTLD=PERTLD+(CCAMPS(2,K)*COSA-CCAMPS(1,K)*SINA)*CCAMPS(5,K)
946  PERTLD=PERTLD+(CCAMPS(2,K)*COSA-CCAMPS(1,K)*SINA)*CCAMPS(5,K);
947 
948 // PERTRD=PERTRD+(CCAMPS(4,K)*COSA-CCAMPS(3,K)*SINA)*CCAMPS(5,K)
949  PERTRD=PERTRD+(CCAMPS(4,K)*COSA-CCAMPS(3,K)*SINA)*CCAMPS(5,K);
950 
951 // 400 CONTINUE
952  }
953 
954 // ESQ=E*E
955  ESQ=E[1]*E[1];
956 
957 // DPARAM=DC1-ESQ
958  DPARAM=DC1-ESQ;
959 
960 // PARAM=DPARAM
961  PARAM=DPARAM;
962 
963 // TWOE=E+E
964  TWOE=E[1]+E[1];
965 
966 // TWOG=G+G
967  TWOG=G[1]+G[1];
968 
969 // PHI=TWOE*((1.0-ESQ*0.125D0)*DSIN(G)+E*0.625D0*DSIN(TWOG)
970 // * +ESQ*0.5416667D0*DSIN(G+TWOG) )
971 
972  PHI=TWOE*((1.0-ESQ*0.125 )*sin(G[1])+E[1]*0.625 *sin(TWOG)
973  +ESQ*0.5416667 *sin(G[1]+TWOG) ) ;
974 
975  //F=G+PHI
976  F=G[1]+PHI;
977 
978  //SINF=DSIN(F)
979  SINF=sin(F);
980 
981  //COSF=DCOS(F)
982  COSF=cos(F);
983 
984  //DPSI=DPARAM/(DC1+E*COSF)
985  DPSI=DPARAM/(DC1+E[1]*COSF);
986 
987 // PHID=TWOE*CCSGD*((1.0+ESQ*1.5D0)*COSF+E[1]*(1.25D0-SINF*SINF*0.5D0))
988  PHID=TWOE*CCSGD*((1.0+ESQ*1.5 )*COSF+E[1]*(1.25 -SINF*SINF*0.5 ));
989 
990 // PSID=CCSGD*E*SINF/SQRT(PARAM)
991  PSID=CCSGD*E[1]*SINF/sqrt(PARAM);
992 
993 // D1PDRO=(DC1+PERTR)
994  D1PDRO=(DC1+PERTR);
995 
996 // DRD=D1PDRO*(PSID+DPSI*PERTRD)
997  DRD=D1PDRO*(PSID+DPSI*PERTRD);
998 
999 // DRLD=D1PDRO*DPSI*(DCSLD+PHID+PERTLD)
1000  DRLD=D1PDRO*DPSI*(DCSLD+PHID+PERTLD);
1001 
1002 // DTL=DMOD(DML+PHI+PERTL, DC2PI)
1003  DTL=fmod(DML+PHI+PERTL, DC2PI);
1004 
1005 // DSINLS=DSIN(DTL)
1006  DSINLS=sin(DTL);
1007 
1008 // DCOSLS=DCOS(DTL)
1009  DCOSLS=cos(DTL);
1010 
1011 // DXHD = DRD*DCOSLS-DRLD*DSINLS
1012  DXHD = DRD*DCOSLS-DRLD*DSINLS;
1013 
1014 // DYHD = DRD*DSINLS+DRLD*DCOSLS
1015  DYHD = DRD*DSINLS+DRLD*DCOSLS;
1016 
1017 // PERTL =0.0
1018  PERTL =0.0;
1019 // PERTLD=0.0
1020  PERTLD=0.0;
1021 // PERTP =0.0
1022  PERTP =0.0;
1023 // PERTPD=0.0
1024  PERTPD=0.0;
1025 
1026  //DO 500 K=1,3
1027  for (K = 1; K <= 3; K++) {
1028  //A=DMOD(DCARGM(1,K)+DT*DCARGM(2,K), DC2PI)
1029  A=fmod(DCARGM(1,K)+DT*DCARGM(2,K), DC2PI);
1030 
1031  //SINA =DSIN(A)
1032  SINA =sin(A);
1033 
1034  //COSA =DCOS(A)
1035  COSA =cos(A);
1036 
1037  //PERTL =PERTL +CCAMPM(1,K)*SINA
1038  PERTL =PERTL +CCAMPM(1,K)*SINA;
1039 
1040  //PERTLD=PERTLD+CCAMPM(2,K)*COSA
1041  PERTLD=PERTLD+CCAMPM(2,K)*COSA;
1042 
1043  //PERTP =PERTP +CCAMPM(3,K)*COSA
1044  PERTP =PERTP +CCAMPM(3,K)*COSA;
1045 
1046  //PERTPD=PERTPD-CCAMPM(4,K)*SINA
1047  PERTPD=PERTPD-CCAMPM(4,K)*SINA;
1048 
1049 // 500 CONTINUE
1050  }
1051 
1052  //TL=FORBEL(2)+PERTL
1053  TL=FORBEL(2)+PERTL;
1054 
1055 // SINLM=DSIN(TL)
1056  SINLM=sin(TL);
1057 
1058 // COSLM=DCOS(TL)
1059  COSLM=cos(TL);
1060 
1061 // SIGMA=CCKM/(1.0+PERTP)
1062  SIGMA=CCKM/(1.0+PERTP);
1063 
1064 // A=SIGMA*(CCMLD+PERTLD)
1065  A=SIGMA*(CCMLD+PERTLD);
1066 
1067 // B=SIGMA*PERTPD
1068  B=SIGMA*PERTPD;
1069 
1070 // DXHD=DXHD+A*SINLM+B*COSLM
1071  DXHD=DXHD+A*SINLM+B*COSLM;
1072 
1073 // DYHD=DYHD-A*COSLM+B*SINLM
1074  DYHD=DYHD-A*COSLM+B*SINLM;
1075 
1076 // DZHD= -SIGMA*CCFDI*DCOS(FORBEL(3))
1077  DZHD= -SIGMA*CCFDI* cos(FORBEL(3));
1078 
1079 // DXBD=DXHD*DC1MME
1080  DXBD=DXHD*DC1MME;
1081 
1082 // DYBD=DYHD*DC1MME
1083  DYBD=DYHD*DC1MME;
1084 // DZBD=DZHD*DC1MME
1085  DZBD=DZHD*DC1MME;
1086 
1087 // DO 600 K=1,4
1088  for (K = 1; K <= 4; K++) {
1089 
1090  //PLON=FORBEL(K+3)
1091  PLON=FORBEL(K+3);
1092 
1093  //POMG=SORBEL(K+1)
1094  POMG=SORBEL(K+1);
1095 
1096  //PECC=SORBEL(K+9)
1097  PECC=SORBEL(K+9);
1098 
1099  //TL=DMOD(PLON+2.0*PECC*DSIN(PLON-POMG), CC2PI)
1100  TL=fmod(PLON+2.0*PECC* sin(PLON-POMG), CC2PI);
1101 
1102  //SINLP(K)=DSIN(TL)
1103  SINLP(K)= sin(TL);
1104 
1105  //COSLP(K)=DCOS(TL)
1106  COSLP(K)= cos(TL);
1107 
1108  //DXBD=DXBD+CCPAMV(K)*(SINLP(K)+PECC*DSIN(POMG))
1109  DXBD=DXBD+CCPAMV(K)*(SINLP(K)+PECC*sin(POMG));
1110 
1111  //DYBD=DYBD-CCPAMV(K)*(COSLP(K)+PECC*DCOS(POMG))
1112  DYBD=DYBD-CCPAMV(K)*(COSLP(K)+PECC*cos(POMG));
1113 
1114  //DZBD=DZBD-CCPAMV(K)*SORBEL(K+13)*DCOS(PLON-SORBEL(K+5))
1115  DZBD=DZBD-CCPAMV(K)*SORBEL(K+13)*cos(PLON-SORBEL(K+5));
1116 
1117 // 600 CONTINUE
1118  }
1119 
1120  //DCOSEP=DCOS(DEPS)
1121  DCOSEP=cos(DEPS);
1122  //DSINEP=DSIN(DEPS)
1123  DSINEP=sin(DEPS);
1124  //DYAHD=DCOSEP*DYHD-DSINEP*DZHD
1125  DYAHD=DCOSEP*DYHD-DSINEP*DZHD;
1126  //DZAHD=DSINEP*DYHD+DCOSEP*DZHD
1127  DZAHD=DSINEP*DYHD+DCOSEP*DZHD;
1128  //DYABD=DCOSEP*DYBD-DSINEP*DZBD
1129  DYABD=DCOSEP*DYBD-DSINEP*DZBD;
1130  //DZABD=DSINEP*DYBD+DCOSEP*DZBD
1131  DZABD=DSINEP*DYBD+DCOSEP*DZBD;
1132 
1133  //DVELH(1)=DXHD
1134  DVELH[1]=DXHD;
1135  //DVELH(2)=DYAHD
1136  DVELH[2]=DYAHD;
1137  //DVELH(3)=DZAHD
1138  DVELH[3]=DZAHD;
1139 
1140  //DVELB(1)=DXBD
1141  DVELB[1]=DXBD;
1142  //DVELB(2)=DYABD
1143  DVELB[2]=DYABD;
1144  //DVELB(3)=DZABD
1145  DVELB[3]=DZABD;
1146  //DO 800 N=1,3
1147  for (N = 1; N <= 3; N++) {
1148  //DVELH(N)=DVELH(N)*1.4959787D8
1149  DVELH[N]=DVELH[N]*1.4959787E8;
1150  //DVELB(N)=DVELB(N)*1.4959787D8
1151  DVELB[N]=DVELB[N]*1.4959787E8;
1152 // 800 CONTINUE
1153  }
1154 // RETURN
1155  return;
1156 }
1157 
1158 /*----------------------------------------------------------------------------*/
1166 /*----------------------------------------------------------------------------*/
1167 
1168 static void
1169 deg2dms(double in_val,
1170  double *degs,
1171  double *minutes,
1172  double *seconds)
1173 {
1174  deg2hms(in_val*15, degs, minutes, seconds);
1175 }
1176 
1180 #define MIDAS_BUG 0
1181 /*----------------------------------------------------------------------------*/
1189 /*----------------------------------------------------------------------------*/
1190 
1191 static void
1192 deg2hms(double in_val,
1193  double *hours,
1194  double *minutes,
1195  double *seconds)
1196 {
1197 // define/parameter p1 ? num "Enter value in deg units"
1198 // define/local in_val/d/1/1 {p1}
1199 //define/local out_val/c/1/80 " " all
1200 //define/local hours/i/1/1 0
1201 //define/local minutes/i/1/1 0
1202 //define/local seconds/d/1/1 0
1203 
1204 //define/local tmp/d/1/1 0
1205  double tmp;
1206 //define/local hold/c/1/80 " " all
1207 //define/local sign/c/1/1 " "
1208 
1209  char sign;
1210 
1211 //hold = "{in_val}"
1212 //if m$index(hold,"-") .gt. 0 then
1213 // in_val = m$abs(in_val)
1214 // sign = "-"
1215 //else
1216 // sign = "+"
1217 //endif
1218  if (in_val < 0) {
1219  in_val = fabs(in_val);
1220  sign = '-';
1221  }
1222  else {
1223  sign = '+';
1224  }
1225 
1226 //set/format i1
1228 // tmp = in_val / 15
1229  tmp = in_val / 15;
1230 
1231 // hours = tmp !takes the integer part = hours
1232 #if MIDAS_BUG
1233  *hours= uves_round_double(tmp);
1234 #else
1235  *hours= (int) tmp;
1236 #endif
1237 
1238 // tmp = tmp - hours !takes the mantissa
1239  tmp = tmp - *hours;
1240 // tmp = tmp * 60 !converts the mantissa in minutes
1241  tmp = tmp * 60;
1242 
1243 // minutes = tmp !takes the integer part = minutes
1244 #if MIDAS_BUG
1245  *minutes= uves_round_double(tmp);
1246 #else
1247  *minutes= (int) tmp;
1248 #endif
1249 
1250 // tmp = tmp - minutes !takes the mantissa
1251  tmp = tmp - *minutes;
1252 
1253 // seconds = tmp * 60 !converts the mantissa in seconds = seconds (with decimal)
1254  *seconds= tmp * 60;
1255 
1256 //out_val = "{sign}{hours},{minutes},{seconds}"
1257 
1258  /* Rather than returning it explicitly, just attach sign to hours */
1259  if (sign == '-') *hours = -(*hours);
1260 
1261  return;
1262 }
1263 
1266 #if 0 /* Not used / needed.
1267  We simply get the julian date from the input FITS header */
1268 
1269 // SUBROUTINE JULDAT(INDATE,UTR,JD)
1270 //C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1271 //C
1272 //C.IDENTIFICATION
1273 //C FORTRAN subroutine JULDAT version 1.0 870102
1274 //C original coding: D. Gillet ESO - Garching
1275 //C variables renamed and restructured: D. Baade ST-ECF, Garching
1276 //C
1277 //C.KEYWORDS
1278 //C geocentric Julian date
1279 //C
1280 //C.PURPOSE
1281 //C calculate geocentric Julian date for any civil date (time in UT)
1282 //C
1283 //C.ALGORITHM
1284 //C adapted from MEEUS J.,1980, ASTRONOMICAL FORMULAE FOR CALCULATORS
1285 //C
1286 //C.INPUT/OUTPUT
1287 //C the following are passed from and to the calling program:
1288 //C INDATE(3) : civil date as year,month,day OR year.fraction
1289 //C UT : universal time expressed in real hours
1290 //C JD : real geocentric Julian date
1291 //C
1292 //C.REVISIONS
1293 //C made to accept also REAL dates D. Baade 910408
1294 //C
1295 //C-------------------------------------------------------------------------------
1296 //C
1297 
1298 static void
1299 juldat(double *INDATE,
1300  double UTR,
1301  double *JD)
1302 {
1303 // DOUBLE PRECISION YP,P,C,A,UT
1304  double UT;
1305 
1306 // DOUBLE PRECISION UTR,JD
1307 //C
1308 // INTEGER STAT,IA,IB,IC,ND,DATE(3)
1309  int DATE[4];
1310 //C
1311 // REAL INDATE(3),FRAC
1312 //C
1313 
1314 // UT=UTR / 24.0D0
1315  UT=UTR / 24.0;
1316 
1317 // CHECK FORMAT OF DATE: may be either year,month,date OR year.fraction,0,0
1318 // (Note that the fraction of the year must NOT include fractions of a day.)
1319 // For all other formats exit and terminate also calling command sequence.
1320 //
1321 // IF ((INDATE(1)-INT(INDATE(1))).GT.1.0E-6) THEN
1322 // IF ((INDATE(2).GT.1.0E-6).OR.(INDATE(3).GT.1.0E-6))
1323 // + CALL STETER(1,'Error: Date was entered in wrong format.')
1324 
1325 // copy date input buffer copy to other buffer so that calling program
1326 // does not notice any changes
1327 
1328 // FIRST CASE: format was year.fraction
1329 
1330 // DATE(1)=INT(INDATE(1))
1331 // FRAC=INDATE(1)-DATE(1)
1332 // DATE(2)=1
1333 // DATE(3)=1
1334 // ELSE
1335 //
1336 // SECOND CASE: format was year,month,day
1337 //
1338 
1339 // DATE(1)=NINT(INDATE(1))
1340  DATE[1]=uves_round_double(INDATE[1]);
1341 
1342  //FRAC=0
1343  FRAC = 0;
1344 
1345  //DATE(2)=NINT(INDATE(2))
1346  DATE[2]=uves_round_double(INDATE[2]);
1347  //DATE(3)=NINT(INDATE(3))
1348  DATE[3]=uves_round_double(INDATE[3]);
1349 
1350  //IF ((DATE(2).EQ.0).AND.(DATE(3).EQ.0)) THEN
1351  if ((DATE[2] == 0) && (DATE[3] == 0)) {
1352  //DATE(2)=1
1353  DATE[2]=1;
1354  //DATE(3)=1
1355  DATE[3]=1;
1356 // ENDIF
1357  }
1358 
1359 // IF ((DATE(2).LT.1).OR.(DATE(2).GT.12))
1360 // + CALL STETER(1,'Error: such a month does not exist')
1361 // IF ((DATE(3).LT.1).OR.(DATE(3).GT.31))
1362 // + CALL STETER(1,'Error: such a day does not exist')
1363 // ENDIF
1364 
1365 // from here on, the normal procedure applies which is based on the
1366 // format year,month,day:
1367 
1368  //IF (DATE(2) .GT. 2) THEN
1369  if (DATE[2] > 2) {
1370  //YP=DATE(1)
1371  YP=DATE[1];
1372  //P=DATE[2]
1373  P=DATE[2];
1374 // ELSE
1375  } else {
1376  //YP=DATE(1)-1
1377  YP=DATE[1]-1;
1378  //P=DATE(2)+12.0
1379  P=DATE(2)+12.0;
1380 // ENDIF
1381  }
1382 
1383 // C = DATE(1) + DATE(2)*1.D-2 + DATE(3)*1.D-4 + UT*1.D-6
1384  C = DATE[1] + DATE[2]*1.E-2 + DATE[3]*1.E-4 + UT*1.E-6;
1385 
1386 // IF (C .GE. 1582.1015D0) THEN
1387  if (C > 1582.1015E0) {
1388  //IA=IDINT(YP/100.D0)
1389  IA=(int) (YP/100.D0);
1390  //A=DBLE(IA)
1391  A=IA;
1392  //IB=2-IA+IDINT(A/4.D0)
1393  IB=2-IA+((int)(A/4.D0));
1394  //ELSE
1395  } else {
1396  //IB=0
1397  IB=0;
1398  //ENDIF
1399  }
1400 
1401 // JD = DINT(365.25D0*YP) + DINT(30.6001D0*(P+1.D0)) + DATE(3) + UT
1402 // * + DBLE(IB) + 1720994.5D0
1403  *JD = ((int) (365.25E0*YP)) + ((int)(30.6001D0*(P+1.D0))) + DATE[3] + UT
1404  + IB + 1720994.5E0;
1405 
1406 // finally, take into account fraction of year (if any), respect leap
1407 // year conventions
1408 //
1409 // IF (FRAC.GT.1.0E-6) THEN
1410  if (FRAC > 1.0E-6) {
1411  //ND=365
1412  ND=365;
1413 
1414  //IF (C.GE.1582.1015D0) THEN
1415  IF (C >= 1582.1015E0) {
1416  //IC = MOD(DATE(1),4)
1417  IC = DATE[1] % 4;
1418  //IF (IC.EQ.0) THEN
1419  if (IC == 0) {
1420  //ND=366
1421  ND=366;
1422  //IC = MOD(DATE(1),100)
1423  IC = DATE[1] % 100;
1424  //IF (IC.EQ.0) THEN
1425  if (IC == 0) {
1426  //IC = MOD(DATE(1),400)
1427  IC = DATE[1] % 400;
1428  //IF (IC.NE.0) ND=365
1429  if (IC != 0) ND=365;
1430  //ENDIF
1431  }
1432  //ENDIF
1433  }
1434  //ENDIF
1435  }
1436 
1437  //IF ( ABS(FRAC*ND-NINT(FRAC*ND)).GT.0.3) THEN
1438  if (fabs(FRAC*ND-uves_round_double(FRAC*ND)) > 0.3) {
1439 // CALL STTPUT
1440 // + ('Warning: Fraction of year MAY not correspond to ',STAT)
1441 // CALL STTPUT(' integer number of days.',STAT)
1442  uves_msg_warning("Fraction of year MAY not correspond to "
1443  "integer number of days");
1444 // ENDIF
1445  }
1446 
1447 // JD = JD+NINT(FRAC*ND)
1448  *JD = *JD+uves_round_double(FRAC*ND);
1449 // ENDIF
1450  }
1451 
1452 // RETURN
1453  return;
1454 }
1455 #endif