uves_baryvel.c

00001 /*                                                                              *
00002  *   This file is part of the ESO UVES Pipeline                                 *
00003  *   Copyright (C) 2004,2005 European Southern Observatory                      *
00004  *                                                                              *
00005  *   This library is free software; you can redistribute it and/or modify       *
00006  *   it under the terms of the GNU General Public License as published by       *
00007  *   the Free Software Foundation; either version 2 of the License, or          *
00008  *   (at your option) any later version.                                        *
00009  *                                                                              *
00010  *   This program is distributed in the hope that it will be useful,            *
00011  *   but WITHOUT ANY WARRANTY; without even the implied warranty of             *
00012  *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *
00013  *   GNU General Public License for more details.                               *
00014  *                                                                              *
00015  *   You should have received a copy of the GNU General Public License          *
00016  *   along with this program; if not, write to the Free Software                *
00017  *   Foundation, 51 Franklin St, Fifth Floor, Boston, MA  02111-1307  USA       *
00018  *                                                                              */
00019 
00020 /*
00021  * $Author: amodigli $
00022  * $Date: 2010/09/24 09:32:02 $
00023  * $Revision: 1.10 $
00024  * $Name: uves-4_9_1 $
00025  * $Log: uves_baryvel.c,v $
00026  * Revision 1.10  2010/09/24 09:32:02  amodigli
00027  * put back QFITS dependency to fix problem spot by NRI on FIBER mode (with MIDAS calibs) data
00028  *
00029  * Revision 1.8  2007/06/06 08:17:33  amodigli
00030  * replace tab with 4 spaces
00031  *
00032  * Revision 1.7  2007/04/24 12:50:29  jmlarsen
00033  * Replaced cpl_propertylist -> uves_propertylist which is much faster
00034  *
00035  * Revision 1.6  2007/03/15 12:33:16  jmlarsen
00036  * Removed redundant explicit array size
00037  *
00038  * Revision 1.5  2006/11/06 15:19:41  jmlarsen
00039  * Removed unused include directives
00040  *
00041  * Revision 1.4  2006/10/05 06:44:58  jmlarsen
00042  * Declared functions static
00043  *
00044  * Revision 1.3  2006/10/04 10:59:04  jmlarsen
00045  * Implemented QC.VRAD parameters
00046  *
00047  * Revision 1.2  2006/10/04 09:55:44  jmlarsen
00048  * Implemented
00049  *
00050  * Revision 1.4  2006/08/17 13:56:52  jmlarsen
00051  * Reduced max line length
00052  *
00053  * Revision 1.3  2005/12/19 16:17:56  jmlarsen
00054  * Replaced bool -> int
00055  *
00056  */
00057 
00058 #ifdef HAVE_CONFIG_H
00059 #  include <config.h>
00060 #endif
00061 
00062 /*----------------------------------------------------------------------------*/
00075 /*----------------------------------------------------------------------------*/
00078 /*-----------------------------------------------------------------------------
00079                                 Includes
00080  -----------------------------------------------------------------------------*/
00081 
00082 #include <uves_baryvel.h>
00083 
00084 #include <uves_pfits.h>
00085 #include <uves_utils.h>
00086 #include <uves_error.h>
00087 #include <uves_msg.h>
00088 
00089 #include <cpl.h>
00090 
00091 #include <math.h>
00092 
00093 /*-----------------------------------------------------------------------------
00094                                 Local functions
00095  -----------------------------------------------------------------------------*/
00096 static void deg2dms(double in_val, 
00097          double *degs,
00098          double *minutes,
00099          double *seconds);
00100 
00101 static void deg2hms(double in_val, 
00102          double *hour,
00103          double *min,
00104          double *sec);
00105 
00106 static void compxy(double inputr[19], char inputc[4],
00107         double outputr[4],
00108         double utr, double mod_juldat);
00109 
00110 static void barvel(double DJE, double DEQ,
00111         double DVELH[4], double DVELB[4]);
00112 
00113 
00114 /*----------------------------------------------------------------------------*/
00121 /*----------------------------------------------------------------------------*/
00122 void
00123 uves_baryvel(const uves_propertylist *raw_header,
00124          double *bary_corr,
00125          double *helio_corr)
00126 {
00127 
00128     double outputr[4];
00129 
00130 //inputc(1:3) = "+++"
00131     char inputc[] = "X+++";       /* 0th index not used */
00132 
00133 //define/local rneg/r/1/1 1.0
00134     double rneg = 1.0;
00135 
00136 //   write/keyw inputr/r/1/18 0.0 all
00137     double inputr[19];                  /* Do not use the zeroth element */
00138 
00139 
00140 /*
00141   qc_ra       = m$value({p1},O_POS(1))
00142   qc_dec      = m$value({p1},O_POS(2))
00143   qc_geolat   = m$value({p1},{h_geolat})
00144   qc_geolon   = m$value({p1},{h_geolon})
00145   qc_obs_time = m$value({p1},O_TIME(7))  !using an image as input it take the
00146                                          !date from the descriptor O_TIME(1,2,3)
00147                                          !and the UT from O_TIME(5)
00148 */
00149     double qc_ra;
00150     double qc_dec;
00151     double qc_geolat;
00152     double qc_geolon;
00153 
00154     double utr;
00155     double mod_juldat;
00156 
00157     double ra_hour, ra_min, ra_sec;
00158     double dec_deg, dec_min, dec_sec;
00159     double lat_deg, lat_min, lat_sec;
00160     double lon_deg, lon_min, lon_sec;
00161 
00162     check( qc_ra       = uves_pfits_get_ra(raw_header),  /* in degrees */
00163        "Error getting object right ascension");
00164     check( qc_dec      = uves_pfits_get_dec(raw_header),
00165        "Error getting object declination");
00166 
00167     check( qc_geolat   = uves_pfits_get_geolat(raw_header),
00168        "Error getting telescope latitude");
00169     check( qc_geolon   = uves_pfits_get_geolon(raw_header),
00170        "Error getting telescope longitude");
00171 
00172     /* double qc_obs_time = uves_pfits_get_exptime(raw_header);   Not used! */
00173 
00174     check( utr         = uves_pfits_get_utc(raw_header),
00175        "Error reading UTC");
00176     check( mod_juldat  = uves_pfits_get_mjdobs(raw_header),
00177        "Error julian date");
00178 
00179     deg2hms(qc_ra,     &ra_hour, &ra_min, &ra_sec);
00180     deg2dms(qc_dec,    &dec_deg, &dec_min, &dec_sec);
00181     deg2dms(qc_geolat, &lat_deg, &lat_min, &lat_sec);
00182     deg2dms(qc_geolon, &lon_deg, &lon_min, &lon_sec);
00183 
00184 //   inputr(1) = m$value({p1},o_time(1))
00185 //   inputr(2) = m$value({p1},o_time(2))
00186 //   inputr(3) = m$value({p1},o_time(3))
00187 //   inputr(4) = m$value({p1},o_time(5))                  !UT in real hours
00188 //    inputr[1] = year;        not needed, pass mjd instead
00189 //    inputr[2] = month;
00190 //    inputr[3] = day;
00191 //    inputr[4] = ut_hour;     not needed, pass ut instead
00192 //    inputr[5] = ut_min;
00193 //    inputr[6] = ut_sec;
00194 
00195 //   write/keyw inputr/r/7/3 {p4}
00196     inputr[7] = lon_deg;
00197     inputr[8] = lon_min;
00198     inputr[9] = lon_sec;
00199 
00200   //rneg = (inputr(7)*3600.)+(inputr(8)*60.)+inputr(9)
00201     rneg = (inputr[7]*3600.)+(inputr[8]*60.)+inputr[9];
00202     //inputc(1:1) = p4(1:1)
00203     inputc[1] = (lon_deg >= 0) ? '+' : '-';
00204     //if rneg .lt. 0.0 inputc(1:1) = "-"
00205     if (rneg < 0) inputc[1] = '-';
00206 
00207 //   write/keyw inputr/r/10/3 {p5},0,0
00208     inputr[10] = lat_deg;
00209     inputr[11] = lat_min;
00210     inputr[12] = lat_sec;
00211 
00212 //  rneg = (inputr(10)*3600.)+(inputr(11)*60.)+inputr(12)
00213     rneg = (inputr[10]*3600.)+(inputr[11]*60.)+inputr[12];
00214 //  inputc(2:2) = p5(1:1)
00215     inputc[2] = (lat_deg >= 0) ? '+' : '-';
00216 //   if rneg .lt. 0.0 inputc(2:2) = "-"
00217     if (rneg < 0) inputc[2] = '-';
00218 
00219 //   write/keyw inputr/r/13/3 {p2},0,0
00220     inputr[13] = ra_hour;
00221     inputr[14] = ra_min;
00222     inputr[15] = ra_sec;
00223 
00224 //   write/keyw inputr/r/16/3 {p3},0,0
00225     inputr[16] = dec_deg;
00226     inputr[17] = dec_min;
00227     inputr[18] = dec_sec;
00228 
00229 //  inputc(3:3) = p3(1:1)
00230     inputc[3] = (dec_deg >= 0) ? '+' : '-';
00231 //  rneg = (inputr(16)*3600.)+(inputr(17)*60.)+inputr(18)
00232     rneg = (inputr[16]*3600.)+(inputr[17]*60.)+inputr[18];
00233 //   if rneg .lt. 0.0 inputc(3:3) = "-"
00234     if (rneg < 0) inputc[3] = '-';
00235     
00236 
00237 //C  INPUTR/R/1/3    date: year,month,day
00238 //C  INPUTR/R/4/3    universal time: hour,min,sec
00239 //C  INPUTR/R/7/3    EAST longitude of observatory: degree,min,sec  !! NOTE
00240 //C  INPUTR/R/10/3   latitude of observatory: degree,min,sec
00241 //C  INPUTR/R/13/3   right ascension: hour,min,sec
00242 //C  INPUTR/R/16/3   declination: degree,min,sec
00243 
00244     //write/keyw action BA                         !indicate barycorr stuff
00245     //run MID_EXE:COMPXY                           !compute the corrections
00246 
00247     compxy(inputr, inputc, outputr, utr, mod_juldat);
00248 
00249 //   set/format f14.6,g24.12
00250 //   uves_msg_debug("        Barycentric correction time:      {outputd(1)} day");
00251 //   uves_msg_debug("        Heliocentric correction time:     {outputd(2)} day");
00252 //   uves_msg_debug(" ");
00253    uves_msg_debug("        Total barycentric RV correction:  %f km/s", outputr[1]);
00254    uves_msg_debug("        Total heliocentric RV correction: %f km/s", outputr[2]);
00255    uves_msg_debug("          (incl. diurnal RV correction of %f km/s)", outputr[3]);
00256 //   uves_msg_debug(" ");
00257 //   uves_msg_debug("Descriptor O_TIME of image {p1} used for date and UT.");
00258 
00259    *bary_corr = outputr[1];
00260    *helio_corr = outputr[2];
00261 
00262   cleanup:
00263    return;
00264 }
00265 
00266 
00267 /*----------------------------------------------------------------------------*/
00289 /*----------------------------------------------------------------------------*/
00290 static void
00291 compxy(double inputr[19], char inputc[4],
00292        double outputr[4],
00293        double utr, double mod_juldat)
00294 {
00295 
00296 //      INTEGER   IAV,STAT,KUN(1),KNUL,N
00297 //      INTEGER   MADRID
00298 //
00299 //      DOUBLE PRECISION   UTR,STR,T0,DL,THETA0,PE,ST0HG,STG,GAST,R1
00300     double STR;
00301 
00302 //    double utr     Not used. Use FITS header value instead
00303     double t0, dl, theta0, pe, st0hg, stg;
00304 //      DOUBLE PRECISION   JD,JD0H,JD00,ZERO
00305     double jd, jd0h;
00306 //      DOUBLE PRECISION   DCORB(3),DCORH(3),DVELB(3),DVELH(3)
00307     double dvelb[4], dvelh[4];
00308 //      DOUBLE PRECISION   ALP,BCT,BEOV,BERV,DEL,EDV
00309     double alp, del, beov, berv, EDV;
00310 //      DOUBLE PRECISION   HAR,HCT,HEOV,HERV,PHI,PI
00311     double HAR, phi, heov, herv;
00312 //      DOUBLE PRECISION   EQX0,EQX1
00313 //      DOUBLE PRECISION   A0R,A1R,D0R,D1R
00314 //      DOUBLE PRECISION   DSMALL,DTEMP(3)
00315 //
00316 //      REAL   DATE0(3),DATE1(3),DATE00(3),A0(3),A1(3),D0(3),D1(3)
00317 //      REAL   DATE(3),UT(3),OLONG(3),ST(3)
00318 //    double ut[4];
00319 //      REAL   OLAT(3),ALPHA(3),DELTA(3)
00320 //      REAL   RBUF(20)
00321     double *rbuf;
00322 //
00323 //      CHARACTER   ACTIO*2,SIGNS*3,INPSGN*3
00324     char inpsgn[4];
00325 //
00326 //      COMMON      /VMR/MADRID(1)
00327 // 
00328 //      DATA    PI  /3.1415926535897928D0/
00329 //      DATA    DSMALL  /1.D-38/
00330 
00331 
00332     double *olong, *olat, *alpha, *delta;
00333 
00334 //1000  SIGNS = '+++'
00335     char signs[] = "+++";
00336 
00337 //      CALL STKRDR('INPUTR',1,20,IAV,RBUF,KUN,KNUL,STAT)
00338     rbuf = inputr;
00339 //      CALL STKRDC('INPUTC',1,1,3,IAV,INPSGN,KUN,KNUL,STAT)
00340     inpsgn[1] = inputc[1];
00341     inpsgn[2] = inputc[2];
00342     inpsgn[3] = inputc[3];
00343 
00344 
00345 //      EQUIVALENCE (RBUF(1),DATE(1)),(RBUF(7),OLONG(1))
00346 //    double *date  = rbuf + 1 - 1;  Not used, use the explicitly passed MJD instead
00347     olong = rbuf + 7 - 1;
00348 //      EQUIVALENCE (RBUF(10),OLAT(1)),(RBUF(13),ALPHA(1))
00349     olat  = rbuf + 10 - 1;
00350     alpha = rbuf + 13 - 1;
00351 //      EQUIVALENCE (RBUF(16),DELTA(1))
00352     delta = rbuf + 16 - 1;
00353 
00354 
00355 
00356 //      DO 1100 N=1,3
00357 //         UT(N) = RBUF(N+3)
00358 //1100  CONTINUE
00359 //    for (n = 1; n <= 3; n++)
00360 //    {
00361 //        ut[n] = rbuf[n+3];
00362 //    }
00363 
00364 // ... convert UT to real hours, calculate Julian date
00365 
00366 //  UTR = UT(1)+UT(2)/60.D0+UT(3)/3600.D0
00367 //    utr = ut[1]+ut[2]/60.  +ut[3]/3600.;   
00368 
00369     /* We know this one already but convert seconds -> hours */
00370     utr /= 3600;
00371 
00372 //      CALL JULDAT(DATE,UTR,JD)
00373     jd = mod_juldat + 2400000.5;
00374   
00375 // ... likewise convert longitude and latitude of observatory to real hours
00376 // ... and degrees, respectively; take care of signs
00377 // ... NOTE: east longitude is assumed for input !!
00378 
00379 //      IF ((OLONG(1).LT.0.0) .OR. (OLONG(2).LT.0.0) .OR.
00380 //     +    (OLONG(3).LT.0.0) .OR. (INPSGN(1:1).EQ.'-')) THEN  
00381       if (olong[1] < 0 || olong[2] < 0 ||
00382           olong[3] < 0 || inpsgn[1] == '-') {
00383 //       SIGNS(1:1) = '-'
00384           signs[1] = '-';
00385 //       OLONG(1) = ABS(OLONG(1))
00386 //       OLONG(2) = ABS(OLONG(2))
00387 //       OLONG(3) = ABS(OLONG(3))
00388           olong[1] = fabs(olong[1]);
00389           olong[2] = fabs(olong[2]);
00390           olong[3] = fabs(olong[3]);
00391 //      ENDIF
00392       }
00393 
00394 //    DL = OLONG(1)+OLONG(2)/60.D0+OLONG(3)/3600.D0
00395       dl = olong[1]+olong[2]/60.  +olong[3]/3600.;
00396 
00397 //    IF (SIGNS(1:1).EQ.'-') DL = -DL              ! negative longitude
00398       if (signs[1]   == '-') dl = -dl;
00399 
00400 //    DL = -DL*24.D0/360.D0                ! convert back to west longitude
00401       dl = -dl*24.  /360.;
00402 
00403 //    IF ((OLAT(1).LT.0.0) .OR. (OLAT(2).LT.0.0) .OR.
00404 //   +    (OLAT(3).LT.0.0) .OR. (INPSGN(2:2).EQ.'-')) THEN  
00405       if (olat[1] < 0 || olat[2] < 0 ||
00406       olat[3] < 0 || inpsgn[2] == '-') {
00407 //        SIGNS(2:2) = '-'
00408       signs[2] = '-';
00409  
00410 //         OLAT(1) = ABS(OLAT(1))
00411 //         OLAT(2) = ABS(OLAT(2))
00412 //         OLAT(3) = ABS(OLAT(3))
00413       olat[1] = fabs(olat[1]);
00414       olat[2] = fabs(olat[2]);
00415       olat[3] = fabs(olat[3]);
00416 //    ENDIF
00417       }
00418 
00419 //    PHI = OLAT(1)+OLAT(2)/60.D0+OLAT(3)/3600.D0
00420       phi = olat[1]+olat[2]/60.  +olat[3]/3600.;
00421 
00422 //    IF (SIGNS(2:2).EQ.'-') PHI = -PHI                 ! negative latitude
00423       if (signs[2]   == '-') phi = -phi;
00424 
00425 //    PHI = PHI*PI/180.D0
00426       phi = phi*M_PI/180. ;
00427 
00428 // ... convert right ascension and declination to real radians
00429 
00430 //    ALP = (ALPHA(1)*3600D0+ALPHA(2)*60D0+ALPHA(3))*PI  /(12.D0*3600.D0)
00431       alp = (alpha[1]*3600. +alpha[2]*60. +alpha[3])*M_PI/(12.  *3600.  );
00432 
00433 //      IF ((DELTA(1).LT.0.0) .OR. (DELTA(2).LT.0.0) .OR.
00434 //     +    (DELTA(3).LT.0.0) .OR. (INPSGN(3:3).EQ.'-')) THEN 
00435       if (delta[1] < 0 || delta[2] < 0 ||
00436       delta[3] < 0 || inpsgn[3] == '-') {
00437 //        SIGNS(3:3) = '-'
00438       signs[3] = '-';
00439 //         DELTA(1) = ABS(DELTA(1))
00440 //         DELTA(2) = ABS(DELTA(2))
00441 //         DELTA(3) = ABS(DELTA(3))
00442       delta[1] = fabs(delta[1]);
00443       delta[2] = fabs(delta[2]);
00444       delta[3] = fabs(delta[3]);
00445 //      ENDIF
00446       }
00447 
00448 //    DEL = (DELTA(1)*3600.D0 + DELTA(2)*60.D0 + DELTA(3))
00449 //     +      * PI/(3600.D0*180.D0)
00450       del = (delta[1]*3600.0  + delta[2]*60.   + delta[3])
00451       * M_PI/(3600. *180. );
00452 
00453 
00454 //    IF (SIGNS(3:3).EQ.'-') DEL = -DEL                 ! negative declination
00455       if (signs[3]   == '-') del = - del;
00456 
00457 // ... calculate earth's orbital velocity in rectangular coordinates X,Y,Z
00458 // ... for both heliocentric and barycentric frames (DVELH, DVELB)
00459 // ... Note that setting the second argument of BARVEL to zero as done below
00460 // ... means that the input coordinates will not be corrected for precession.
00461 
00462 //      CALL BARVEL(JD,0.0D0,DVELH,DVELB)
00463       barvel(jd, 0.0, dvelh, dvelb);
00464 
00465 // ... with the rectangular velocity components known, the respective projections
00466 // ... HEOV and BEOV on a given line of sight (ALP,DEL) can be determined:
00467 
00468 // ... REFERENCE: THE ASTRONOMICAL ALMANAC 1982 PAGE:B17
00469 
00470 //      BEOV=DVELB(1)*DCOS(ALP)*DCOS(DEL)+
00471 //     1     DVELB(2)*DSIN(ALP)*DCOS(DEL)+
00472 //     2     DVELB(3)*DSIN(DEL)
00473       beov =
00474       dvelb[1]*cos(alp)*cos(del)+
00475       dvelb[2]*sin(alp)*cos(del)+
00476       dvelb[3]*sin(del);
00477       
00478 //      HEOV=DVELH(1)*DCOS(ALP)*DCOS(DEL)+
00479 //     1     DVELH(2)*DSIN(ALP)*DCOS(DEL)+
00480 //     2     DVELH(3)*DSIN(DEL)
00481       heov =
00482       dvelh[1]*cos(alp)*cos(del)+
00483       dvelh[2]*sin(alp)*cos(del)+
00484       dvelh[3]*sin(del);
00485       
00486 
00487 // ... For determination also of the contribution due to the diurnal rotation of
00488 // ... the earth (EDV), the hour angle (HAR) is needed at which the observation
00489 // ... was made which requires conversion of UT to sidereal time (ST).
00490 
00491 // ... Therefore, first compute ST at 0 hours UT (ST0HG)
00492 
00493 // ... REFERENCE : MEEUS J.,1980,ASTRONOMICAL FORMULAE FOR CALCULATORS
00494 
00495 //      CALL JULDAT(DATE,ZERO,JD0H)
00496       jd0h = jd - (utr/24.0);
00497       
00498 //      T0=(JD0H-2415020.D0)/36525.D0
00499       t0 = (jd0h-2415020.  )/36525. ;
00500       
00501 //      THETA0=0.276919398D0+100.0021359D0*T0+0.000001075D0*T0*T0
00502       theta0 = 0.276919398  +100.0021359  *t0+0.000001075  *t0*t0 ;
00503 
00504 //      PE=DINT(THETA0)
00505       pe = (int) theta0;
00506 
00507 //      THETA0=THETA0-PE
00508       theta0 = theta0 - pe;
00509 
00510 //      ST0HG=THETA0*24.D0
00511       st0hg = theta0*24. ;
00512 
00513 // ... now do the conversion UT -> ST (MEAN SIDEREAL TIME)
00514 
00515 // ... REFERENCE : THE ASTRONOMICAL ALMANAC 1983, P B7
00516 // ... IN 1983: 1 MEAN SOLAR DAY = 1.00273790931 MEAN SIDEREAL DAYS
00517 // ... ST WITHOUT EQUATION OF EQUINOXES CORRECTION => ACCURACY +/- 1 SEC
00518 //
00519 //      STG=ST0HG+UTR*1.00273790931D0
00520       stg = st0hg+utr*1.00273790931 ;
00521       
00522 //      IF (STG.LT.DL) STG=STG+24.D0
00523       if (stg < dl) stg = stg +24. ;
00524 
00525 //      STR=STG-DL
00526       STR = stg-dl;
00527 
00528 //      IF (STR.GE.24.D0) STR=STR-24.D0
00529       if (STR >= 24. ) STR = STR-24. ;
00530 
00531 //      STR = STR*PI/12.D0                                 ! ST in radians
00532       STR = STR*M_PI/12. ;
00533 
00534 //      HAR=STR-ALP                                     ! hour angle of observation
00535       HAR = STR-alp;
00536       
00537 //      EDV=-0.4654D0*DSIN(HAR)*DCOS(DEL)*DCOS(PHI)
00538       EDV = -0.4654  * sin(HAR)* cos(del)* cos(phi);
00539 
00540 // ... the total correction (in km/s) is the sum of orbital and diurnal components
00541 
00542 //    HERV=HEOV+EDV
00543       herv=heov+EDV;
00544 //    BERV=BEOV+EDV
00545       berv=beov+EDV;
00546 
00547       /* The following is not needed. Do not translate */
00548 
00549 #if 0
00550 // ... Calculation of the barycentric and heliocentric correction times
00551 // ... (BCT and HCT) requires knowledge of the earth's position in its
00552 // ... orbit. Subroutine BARCOR returns the rectangular barycentric (DCORB)
00553 // ... and heliocentric (DCORH) coordinates.
00554 
00555 //      CALL BARCOR(DCORH,DCORB)
00556 
00557 // ... from this, the correction times (in days) can be determined:
00558 // ... (REFERENCE: THE ASTRONOMICAL ALMANAC 1982 PAGE:B16)
00559 
00560 //      BCT=+0.0057756D0*(DCORB(1)*DCOS(ALP)*DCOS(DEL)+
00561 //     1                DCORB(2)*DSIN(ALP)*DCOS(DEL)+
00562 //     2                DCORB(3)*          DSIN(DEL))
00563 //      HCT=+0.0057756D0*(DCORH(1)*DCOS(ALP)*DCOS(DEL)+
00564 //     1                DCORH(2)*DSIN(ALP)*DCOS(DEL)+
00565 //     2                DCORH(3)*          DSIN(DEL))
00566 
00567 //... write results to keywords
00568 
00569 //      CALL STKWRD('OUTPUTD',BCT,1,1,KUN,STAT)    ! barycentric correction time
00570 //      CALL STKWRD('OUTPUTD',HCT,2,1,KUN,STAT)    ! heliocentric correction time
00571 #endif
00572 
00573 
00574 //      RBUF(1) = BERV                             ! barocentric RV correction
00575 //      RBUF(2) = HERV                             ! heliocentric RV correction
00576 // ... (note that EDV is already contained in both BERV and HERV)
00577 //      RBUF(3) = EDV                              ! diurnal RV correction
00578       rbuf[1] = berv;
00579       rbuf[2] = herv;
00580       rbuf[3] = EDV;
00581 
00582 //      CALL STKWRR('OUTPUTR',RBUF,1,3,KUN,STAT)
00583       outputr[1] = rbuf[1];
00584       outputr[2] = rbuf[2];
00585       outputr[3] = rbuf[3];
00586 //      GOTO 9000
00587       return;
00588 }
00589 
00590 /* @cond Convert FORTRAN indexing -> C indexing */
00591 #define DCFEL(x,y)  dcfel[y][x]
00592 #define DCFEPS(x,y) dcfeps[y][x]
00593 #define CCSEL(x,y)  ccsel[y][x]
00594 #define DCARGS(x,y) dcargs[y][x]
00595 #define CCAMPS(x,y) ccamps[y][x]
00596 #define CCSEC(x,y)  ccsec[y][x]
00597 #define DCARGM(x,y) dcargm[y][x]
00598 #define CCAMPM(x,y) ccampm[y][x]
00599 #define DCEPS(x)    dceps[x]
00600 #define FORBEL(x)   forbel[x]
00601 #define SORBEL(x)   sorbel[x]
00602 #define SN(x)       sn[x]
00603 #define SINLP(x)    sinlp[x]
00604 #define COSLP(x)    coslp[x]
00605 #define CCPAMV(x)   ccpamv[x]
00606 /* @endcond */
00607 /*----------------------------------------------------------------------------*/
00620 /*----------------------------------------------------------------------------*/
00621 
00622 //      SUBROUTINE BARVEL(DJE,DEQ,DVELH,DVELB)
00623 
00624 static 
00625 void barvel(double DJE, double DEQ,
00626         double DVELH[4], double DVELB[4])
00627 {
00628 //      DOUBLE PRECISION   DJE,DEQ,DVELH(3),DVELB(3),SN(4)
00629     double sn[5];
00630 //      DOUBLE PRECISION   DT,DTL,DCT0,DCJUL,DTSQ,DLOCAL,DC2PI,CC2PI
00631     double DT,DTL,DTSQ,DLOCAL;
00632 //      DOUBLE PRECISION   DRD,DRLD,DCSLD,DC1
00633     double DRD,DRLD;
00634 //      DOUBLE PRECISION   DXBD,DYBD,DZBD,DZHD,DXHD,DYHD
00635     double DXBD,DYBD,DZBD,DZHD,DXHD,DYHD;
00636 //      DOUBLE PRECISION   DYAHD,DZAHD,DYABD,DZABD
00637     double DYAHD,DZAHD,DYABD,DZABD;
00638 //      DOUBLE PRECISION   DML,DEPS,PHI,PHID,PSID,DPARAM,PARAM
00639     double DML,DEPS,PHI,PHID,PSID,DPARAM,PARAM;
00640 //      DOUBLE PRECISION   CCFDI,CCKM,CCMLD,PLON,POMG,PECC
00641     double PLON,POMG,PECC;
00642 //      DOUBLE PRECISION   PERTL,PERTLD,PERTRD,PERTP,PERTR,PERTPD
00643     double PERTL,PERTLD,PERTRD,PERTP,PERTR,PERTPD;
00644 //      DOUBLE PRECISION   SINA,CCSGD,DC1MME,TL
00645     double SINA,TL;
00646 //      DOUBLE PRECISION   CCSEC3,COSA,ESQ
00647     double COSA,ESQ;
00648 //      DOUBLE PRECISION   DCFEL(3,8),DCEPS(3),CCSEL(3,17),DCARGS(2,15)
00649 //      DOUBLE PRECISION   CCAMPS(5,15),CCSEC(3,4),DCARGM(2,3)
00650 //      DOUBLE PRECISION   CCAMPM(4,3),CCPAMV(4)
00651 //      DOUBLE PRECISION   A,B,E,F,G,SINF,COSF,T,TSQ,TWOE,TWOG
00652     double A,B,F,SINF,COSF,T,TSQ,TWOE,TWOG;
00653 //C
00654 //      DOUBLE PRECISION   DPREMA(3,3),DPSI,D1PDRO,DSINLS
00655     double DPSI,D1PDRO,DSINLS;
00656 //      DOUBLE PRECISION   DCOSLS,DSINEP,DCOSEP
00657     double DCOSLS,DSINEP,DCOSEP;
00658 //      DOUBLE PRECISION   FORBEL(7),SORBEL(17),SINLP(4),COSLP(4)
00659     double forbel[8], sorbel[18], sinlp[5], coslp[5];
00660 //      DOUBLE PRECISION   SINLM,COSLM,SIGMA
00661     double SINLM,COSLM,SIGMA;
00662 //C
00663 //      INTEGER     IDEQ,K,N
00664     int IDEQ,K,N;
00665 //C
00666 //      COMMON /BARXYZ/    DPREMA,DPSI,D1PDRO,DSINLS,DCOSLS,
00667 //     +                   DSINEP,DCOSEP,FORBEL,SORBEL,SINLP,
00668 //     +                   COSLP,SINLM,COSLM,SIGMA,IDEQ
00669 
00670 //      EQUIVALENCE (SORBEL(1),E),(FORBEL(1),G)
00671     double *E = sorbel + 1 - 1;
00672     double *G = forbel + 1 - 1;
00673 //C
00674 //      DATA DC2PI/6.2831853071796D0/,CC2PI/6.283185/,
00675     double DC2PI = 6.2831853071796E0;
00676     double CC2PI = 6.283185;             /* ??? */
00677 
00678 //     *DC1/1.0D0/,DCT0/2415020.0D0/,DCJUL/36525.0D0/
00679     double DC1 = 1.0;
00680     double DCT0 = 2415020.0E0;
00681     double DCJUL = 36525.0E0;
00682 //C
00683 //      DATA DCFEL/ 1.7400353D+00, 6.2833195099091D+02, 5.2796D-06,
00684 //     *            6.2565836D+00, 6.2830194572674D+02,-2.6180D-06,
00685 //     *            4.7199666D+00, 8.3997091449254D+03,-1.9780D-05,
00686 //     *            1.9636505D-01, 8.4334662911720D+03,-5.6044D-05,
00687 //     *            4.1547339D+00, 5.2993466764997D+01, 5.8845D-06,
00688 //     *            4.6524223D+00, 2.1354275911213D+01, 5.6797D-06,
00689 //     *            4.2620486D+00, 7.5025342197656D+00, 5.5317D-06,
00690 //     *            1.4740694D+00, 3.8377331909193D+00, 5.6093D-06/
00691 
00692     double dcfel[][4] = { {0, 0, 0, 0},
00693               {0, 1.7400353E+00, 6.2833195099091E+02, 5.2796E-06},
00694               {0, 6.2565836E+00, 6.2830194572674E+02,-2.6180E-06},
00695               {0, 4.7199666E+00, 8.3997091449254E+03,-1.9780E-05},
00696               {0, 1.9636505E-01, 8.4334662911720E+03,-5.6044E-05},
00697               {0, 4.1547339E+00, 5.2993466764997E+01, 5.8845E-06},
00698               {0, 4.6524223E+00, 2.1354275911213E+01, 5.6797E-06},
00699               {0, 4.2620486E+00, 7.5025342197656E+00, 5.5317E-06},
00700               {0, 1.4740694E+00, 3.8377331909193E+00, 5.6093E-06} };
00701     
00702 //C
00703 //      DATA DCEPS/ 4.093198D-01,-2.271110D-04,-2.860401D-08/
00704     double dceps[4] = {0, 4.093198E-01,-2.271110E-04,-2.860401E-08};
00705 
00706 //C
00707 //      DATA CCSEL/ 1.675104D-02,-4.179579D-05,-1.260516D-07,
00708 //     *            2.220221D-01, 2.809917D-02, 1.852532D-05,
00709 //     *            1.589963D+00, 3.418075D-02, 1.430200D-05,
00710 //     *            2.994089D+00, 2.590824D-02, 4.155840D-06,
00711 //     *            8.155457D-01, 2.486352D-02, 6.836840D-06,
00712 //     *            1.735614D+00, 1.763719D-02, 6.370440D-06,
00713 //     *            1.968564D+00, 1.524020D-02,-2.517152D-06,
00714 //     *            1.282417D+00, 8.703393D-03, 2.289292D-05,
00715 //     *            2.280820D+00, 1.918010D-02, 4.484520D-06,
00716 //     *            4.833473D-02, 1.641773D-04,-4.654200D-07,
00717 //     *            5.589232D-02,-3.455092D-04,-7.388560D-07,
00718 //     *            4.634443D-02,-2.658234D-05, 7.757000D-08,
00719 //     *            8.997041D-03, 6.329728D-06,-1.939256D-09,
00720 //     *            2.284178D-02,-9.941590D-05, 6.787400D-08,
00721 //     *            4.350267D-02,-6.839749D-05,-2.714956D-07,
00722 //     *            1.348204D-02, 1.091504D-05, 6.903760D-07,
00723 //     *            3.106570D-02,-1.665665D-04,-1.590188D-07/
00724 
00725     double ccsel[][4] = { {0, 0, 0, 0},
00726               {0, 1.675104E-02, -4.179579E-05, -1.260516E-07},
00727               {0, 2.220221E-01,  2.809917E-02,  1.852532E-05},
00728               {0, 1.589963E+00,  3.418075E-02,  1.430200E-05},
00729               {0, 2.994089E+00,  2.590824E-02,  4.155840E-06},
00730               {0, 8.155457E-01,  2.486352E-02,  6.836840E-06},
00731               {0, 1.735614E+00,  1.763719E-02,  6.370440E-06},
00732               {0, 1.968564E+00,  1.524020E-02, -2.517152E-06},
00733               {0, 1.282417E+00,  8.703393E-03,  2.289292E-05},
00734               {0, 2.280820E+00,  1.918010E-02,  4.484520E-06},
00735               {0, 4.833473E-02,  1.641773E-04, -4.654200E-07},
00736               {0, 5.589232E-02, -3.455092E-04, -7.388560E-07},
00737               {0, 4.634443E-02, -2.658234E-05,  7.757000E-08},
00738               {0, 8.997041E-03,  6.329728E-06, -1.939256E-09},
00739               {0, 2.284178E-02, -9.941590E-05,  6.787400E-08},
00740               {0, 4.350267E-02, -6.839749E-05, -2.714956E-07},
00741               {0, 1.348204E-02,  1.091504E-05,  6.903760E-07},
00742               {0, 3.106570E-02, -1.665665E-04, -1.590188E-07} };
00743 
00744 
00745 
00746 //      DATA DCARGS/ 5.0974222D+00,-7.8604195454652D+02,
00747 //     *             3.9584962D+00,-5.7533848094674D+02,
00748 //     *             1.6338070D+00,-1.1506769618935D+03,
00749 //     *             2.5487111D+00,-3.9302097727326D+02,
00750 //     *             4.9255514D+00,-5.8849265665348D+02,
00751 //     *             1.3363463D+00,-5.5076098609303D+02,
00752 //     *             1.6072053D+00,-5.2237501616674D+02,
00753 //     *             1.3629480D+00,-1.1790629318198D+03,
00754 //     *             5.5657014D+00,-1.0977134971135D+03,
00755 //     *             5.0708205D+00,-1.5774000881978D+02,
00756 //     *             3.9318944D+00, 5.2963464780000D+01,
00757 //     *             4.8989497D+00, 3.9809289073258D+01,
00758 //     *             1.3097446D+00, 7.7540959633708D+01,
00759 //     *             3.5147141D+00, 7.9618578146517D+01,
00760 //     *             3.5413158D+00,-5.4868336758022D+02/
00761 
00762     double dcargs[][3] = { {0, 0, 0},
00763                {0, 5.0974222E+00, -7.8604195454652E+02},
00764                {0, 3.9584962E+00, -5.7533848094674E+02},
00765                {0, 1.6338070E+00, -1.1506769618935E+03},
00766                {0, 2.5487111E+00, -3.9302097727326E+02},
00767                {0, 4.9255514E+00, -5.8849265665348E+02},
00768                {0, 1.3363463E+00, -5.5076098609303E+02},
00769                {0, 1.6072053E+00, -5.2237501616674E+02},
00770                {0, 1.3629480E+00, -1.1790629318198E+03},
00771                {0, 5.5657014E+00, -1.0977134971135E+03},
00772                {0, 5.0708205E+00, -1.5774000881978E+02},
00773                {0, 3.9318944E+00,  5.2963464780000E+01},
00774                {0, 4.8989497E+00,  3.9809289073258E+01},
00775                {0, 1.3097446E+00,  7.7540959633708E+01},
00776                {0, 3.5147141E+00,  7.9618578146517E+01},
00777                {0, 3.5413158E+00, -5.4868336758022E+02} };
00778 
00779 //      DATA CCAMPS/
00780 //     *-2.279594D-5, 1.407414D-5, 8.273188D-6, 1.340565D-5,-2.490817D-7,
00781 //     *-3.494537D-5, 2.860401D-7, 1.289448D-7, 1.627237D-5,-1.823138D-7,
00782 //     * 6.593466D-7, 1.322572D-5, 9.258695D-6,-4.674248D-7,-3.646275D-7,
00783 //     * 1.140767D-5,-2.049792D-5,-4.747930D-6,-2.638763D-6,-1.245408D-7,
00784 //     * 9.516893D-6,-2.748894D-6,-1.319381D-6,-4.549908D-6,-1.864821D-7,
00785 //     * 7.310990D-6,-1.924710D-6,-8.772849D-7,-3.334143D-6,-1.745256D-7,
00786 //     *-2.603449D-6, 7.359472D-6, 3.168357D-6, 1.119056D-6,-1.655307D-7,
00787 //     *-3.228859D-6, 1.308997D-7, 1.013137D-7, 2.403899D-6,-3.736225D-7,
00788 //     * 3.442177D-7, 2.671323D-6, 1.832858D-6,-2.394688D-7,-3.478444D-7,
00789 //     * 8.702406D-6,-8.421214D-6,-1.372341D-6,-1.455234D-6,-4.998479D-8,
00790 //     *-1.488378D-6,-1.251789D-5, 5.226868D-7,-2.049301D-7, 0.0D0,
00791 //     *-8.043059D-6,-2.991300D-6, 1.473654D-7,-3.154542D-7, 0.0D0,
00792 //     * 3.699128D-6,-3.316126D-6, 2.901257D-7, 3.407826D-7, 0.0D0,
00793 //     * 2.550120D-6,-1.241123D-6, 9.901116D-8, 2.210482D-7, 0.0D0,
00794 //     *-6.351059D-7, 2.341650D-6, 1.061492D-6, 2.878231D-7, 0.0D0/
00795 
00796     double ccamps[][6] = 
00797     {{0, 0, 0, 0, 0, 0},
00798      {0, -2.279594E-5,  1.407414E-5,  8.273188E-6,  1.340565E-5, -2.490817E-7},
00799      {0, -3.494537E-5,  2.860401E-7,  1.289448E-7,  1.627237E-5, -1.823138E-7},
00800      {0,  6.593466E-7,  1.322572E-5,  9.258695E-6, -4.674248E-7, -3.646275E-7},
00801      {0,  1.140767E-5, -2.049792E-5, -4.747930E-6, -2.638763E-6, -1.245408E-7},
00802      {0,  9.516893E-6, -2.748894E-6, -1.319381E-6, -4.549908E-6, -1.864821E-7},
00803      {0,  7.310990E-6, -1.924710E-6, -8.772849E-7, -3.334143E-6, -1.745256E-7},
00804      {0, -2.603449E-6,  7.359472E-6,  3.168357E-6,  1.119056E-6, -1.655307E-7},
00805      {0, -3.228859E-6,  1.308997E-7,  1.013137E-7,  2.403899E-6, -3.736225E-7},
00806      {0,  3.442177E-7,  2.671323E-6,  1.832858E-6, -2.394688E-7, -3.478444E-7},
00807      {0,  8.702406E-6, -8.421214E-6, -1.372341E-6, -1.455234E-6, -4.998479E-8},
00808      {0, -1.488378E-6, -1.251789E-5,  5.226868E-7, -2.049301E-7,  0.0E0},
00809      {0, -8.043059E-6, -2.991300E-6,  1.473654E-7, -3.154542E-7,  0.0E0},
00810      {0,  3.699128E-6, -3.316126E-6,  2.901257E-7,  3.407826E-7,  0.0E0},
00811      {0,  2.550120E-6, -1.241123E-6,  9.901116E-8,  2.210482E-7,  0.0E0},
00812      {0, -6.351059E-7,  2.341650E-6,  1.061492E-6,  2.878231E-7,  0.0E0}};
00813 
00814 
00815 //      DATA CCSEC3/-7.757020D-08/
00816     double CCSEC3 = -7.757020E-08;
00817 //C
00818 //      DATA CCSEC/ 1.289600D-06, 5.550147D-01, 2.076942D+00,
00819 //     *            3.102810D-05, 4.035027D+00, 3.525565D-01,
00820 //     *            9.124190D-06, 9.990265D-01, 2.622706D+00,
00821 //     *            9.793240D-07, 5.508259D+00, 1.559103D+01/
00822 
00823     double ccsec[][4] = { {0, 0, 0, 0},
00824               {0, 1.289600E-06,  5.550147E-01,  2.076942E+00},
00825               {0, 3.102810E-05,  4.035027E+00,  3.525565E-01},
00826               {0, 9.124190E-06,  9.990265E-01,  2.622706E+00},
00827               {0, 9.793240E-07,  5.508259E+00,  1.559103E+01}};
00828 
00829 //C
00830 //      DATA DCSLD/ 1.990987D-07/, CCSGD/ 1.990969D-07/
00831     double DCSLD =  1.990987E-07, CCSGD = 1.990969E-07;
00832 //C
00833 //      DATA CCKM/3.122140D-05/, CCMLD/2.661699D-06/, CCFDI/2.399485D-07/
00834     double CCKM = 3.122140E-05, CCMLD = 2.661699E-06, CCFDI = 2.399485E-07;
00835 //C
00836 //      DATA DCARGM/ 5.1679830D+00, 8.3286911095275D+03,
00837 //     *             5.4913150D+00,-7.2140632838100D+03,
00838 //     *             5.9598530D+00, 1.5542754389685D+04/
00839 
00840     double dcargm[][3] = {{0, 0, 0},
00841               {0, 5.1679830E+00,  8.3286911095275E+03},
00842               {0, 5.4913150E+00, -7.2140632838100E+03},
00843               {0, 5.9598530E+00,  1.5542754389685E+04}};
00844 //C
00845 //      DATA CCAMPM/
00846 //     *  1.097594D-01, 2.896773D-07, 5.450474D-02, 1.438491D-07,
00847 //     * -2.223581D-02, 5.083103D-08, 1.002548D-02,-2.291823D-08,
00848 //     *  1.148966D-02, 5.658888D-08, 8.249439D-03, 4.063015D-08/
00849 
00850     double ccampm[][5] = {{0, 0, 0, 0, 0},
00851               {0,  1.097594E-01,  2.896773E-07,  5.450474E-02,  1.438491E-07},
00852               {0, -2.223581E-02,  5.083103E-08,  1.002548E-02, -2.291823E-08},
00853               {0,  1.148966E-02,  5.658888E-08,  8.249439E-03,  4.063015E-08} };
00854 
00855 //C
00856 //      DATA CCPAMV/8.326827D-11,1.843484D-11,1.988712D-12,1.881276D-12/,
00857     double ccpamv[] = {0, 8.326827E-11, 1.843484E-11, 1.988712E-12, 1.881276E-12};
00858 //     *     DC1MME/0.99999696D0/
00859     double DC1MME = 0.99999696E0;
00860 //C
00861 
00862 //  IDEQ=DEQ
00863     IDEQ=DEQ;
00864 
00865 //  DT=(DJE-DCT0)/DCJUL
00866     DT=(DJE-DCT0)/DCJUL;
00867 
00868 //  T=DT
00869     T=DT;
00870 
00871 //  DTSQ=DT*DT
00872     DTSQ=DT*DT;
00873 
00874 //  TSQ=DTSQ
00875     TSQ=DTSQ;
00876 
00877     DML = 0;  /* Suppress warning */
00878 //      DO 100, K=1,8
00879     for (K = 1; K <= 8; K++) {
00880 
00881 //      DLOCAL=DMOD(DCFEL(1,K)+DT*DCFEL(2,K)+DTSQ*DCFEL(3,K),DC2PI)
00882     DLOCAL=fmod(DCFEL(1,K)+DT*DCFEL(2,K)+DTSQ*DCFEL(3,K),DC2PI);
00883 
00884 //      IF (K.EQ.1)  DML=DLOCAL
00885     if (K == 1)  DML=DLOCAL;
00886 
00887 //      IF (K.NE.1)  FORBEL(K-1)=DLOCAL
00888     if (K != 1)  FORBEL(K-1)=DLOCAL;
00889 //  100 CONTINUE
00890     }
00891 
00892 //  DEPS=DMOD(DCEPS(1)+DT*DCEPS(2)+DTSQ*DCEPS(3), DC2PI)
00893     DEPS=fmod(DCEPS(1)+DT*DCEPS(2)+DTSQ*DCEPS(3), DC2PI);
00894 
00895 //      DO 200, K=1,17
00896     for (K = 1; K <= 17; K++) {
00897 
00898 //      SORBEL(K)=DMOD(CCSEL(1,K)+T*CCSEL(2,K)+TSQ*CCSEL(3,K),CC2PI)
00899     SORBEL(K)=fmod(CCSEL(1,K)+T*CCSEL(2,K)+TSQ*CCSEL(3,K),CC2PI);
00900 
00901 //  200 CONTINUE
00902     }
00903 
00904 //      DO 300, K=1,4
00905     for (K = 1; K <= 4; K++) {
00906 
00907 //      A=DMOD(CCSEC(2,K)+T*CCSEC(3,K),CC2PI)
00908     A=fmod(CCSEC(2,K)+T*CCSEC(3,K),CC2PI);
00909     
00910 //      SN(K)=DSIN(A)
00911     SN(K)=sin(A);
00912 //  300 CONTINUE
00913     }
00914 
00915 //      PERTL =  CCSEC(1,1)          *SN(1) +CCSEC(1,2)*SN(2)
00916 //     *       +(CCSEC(1,3)+T*CCSEC3)*SN(3) +CCSEC(1,4)*SN(4)
00917 
00918     PERTL =  CCSEC(1,1)          *SN(1) +CCSEC(1,2)*SN(2)
00919            +(CCSEC(1,3)+T*CCSEC3)*SN(3) +CCSEC(1,4)*SN(4);
00920 
00921 //    PERTLD=0.0
00922 //    PERTR =0.0
00923 //    PERTRD=0.0
00924     PERTLD=0.0;
00925     PERTR =0.0;
00926     PERTRD=0.0;
00927 
00928 //      DO 400, K=1,15
00929     for (K = 1; K <= 15; K++) {
00930 //      A=DMOD(DCARGS(1,K)+DT*DCARGS(2,K), DC2PI)
00931     A=fmod(DCARGS(1,K)+DT*DCARGS(2,K), DC2PI);
00932 
00933 //    COSA=DCOS(A)
00934     COSA=cos(A);
00935 
00936 //      SINA=DSIN(A)
00937     SINA=sin(A);
00938 
00939 //      PERTL =PERTL+CCAMPS(1,K)*COSA+CCAMPS(2,K)*SINA
00940     PERTL =PERTL+CCAMPS(1,K)*COSA+CCAMPS(2,K)*SINA;
00941 
00942 //    PERTR =PERTR+CCAMPS(3,K)*COSA+CCAMPS(4,K)*SINA;
00943     PERTR =PERTR+CCAMPS(3,K)*COSA+CCAMPS(4,K)*SINA;
00944 
00945 //         IF (K.GE.11) GO TO 400
00946     if (K >= 11) break;
00947 
00948 //      PERTLD=PERTLD+(CCAMPS(2,K)*COSA-CCAMPS(1,K)*SINA)*CCAMPS(5,K)
00949     PERTLD=PERTLD+(CCAMPS(2,K)*COSA-CCAMPS(1,K)*SINA)*CCAMPS(5,K);
00950 
00951 //      PERTRD=PERTRD+(CCAMPS(4,K)*COSA-CCAMPS(3,K)*SINA)*CCAMPS(5,K)
00952     PERTRD=PERTRD+(CCAMPS(4,K)*COSA-CCAMPS(3,K)*SINA)*CCAMPS(5,K);
00953 
00954 //  400 CONTINUE
00955     }
00956 
00957 //  ESQ=E*E
00958     ESQ=E[1]*E[1];
00959 
00960 //  DPARAM=DC1-ESQ
00961     DPARAM=DC1-ESQ;
00962 
00963 //  PARAM=DPARAM
00964     PARAM=DPARAM;
00965 
00966 //  TWOE=E+E
00967     TWOE=E[1]+E[1];
00968 
00969 //  TWOG=G+G
00970     TWOG=G[1]+G[1];
00971 
00972 //      PHI=TWOE*((1.0-ESQ*0.125D0)*DSIN(G)+E*0.625D0*DSIN(TWOG)
00973 //    *          +ESQ*0.5416667D0*DSIN(G+TWOG) )
00974 
00975     PHI=TWOE*((1.0-ESQ*0.125  )*sin(G[1])+E[1]*0.625  *sin(TWOG)
00976           +ESQ*0.5416667  *sin(G[1]+TWOG) ) ;
00977     
00978     //F=G+PHI
00979     F=G[1]+PHI;
00980 
00981     //SINF=DSIN(F)
00982     SINF=sin(F);
00983 
00984     //COSF=DCOS(F)
00985     COSF=cos(F);
00986 
00987     //DPSI=DPARAM/(DC1+E*COSF)
00988     DPSI=DPARAM/(DC1+E[1]*COSF);
00989 
00990 //  PHID=TWOE*CCSGD*((1.0+ESQ*1.5D0)*COSF+E[1]*(1.25D0-SINF*SINF*0.5D0))
00991     PHID=TWOE*CCSGD*((1.0+ESQ*1.5  )*COSF+E[1]*(1.25  -SINF*SINF*0.5  ));
00992 
00993 //  PSID=CCSGD*E*SINF/SQRT(PARAM)
00994     PSID=CCSGD*E[1]*SINF/sqrt(PARAM);
00995 
00996 //  D1PDRO=(DC1+PERTR)
00997     D1PDRO=(DC1+PERTR);
00998 
00999 //  DRD=D1PDRO*(PSID+DPSI*PERTRD)
01000     DRD=D1PDRO*(PSID+DPSI*PERTRD);
01001 
01002 //  DRLD=D1PDRO*DPSI*(DCSLD+PHID+PERTLD)
01003     DRLD=D1PDRO*DPSI*(DCSLD+PHID+PERTLD);
01004 
01005 //  DTL=DMOD(DML+PHI+PERTL, DC2PI)
01006     DTL=fmod(DML+PHI+PERTL, DC2PI);
01007 
01008 //  DSINLS=DSIN(DTL)
01009     DSINLS=sin(DTL);
01010 
01011 //  DCOSLS=DCOS(DTL)
01012     DCOSLS=cos(DTL);
01013 
01014 //  DXHD = DRD*DCOSLS-DRLD*DSINLS
01015     DXHD = DRD*DCOSLS-DRLD*DSINLS;
01016 
01017 //  DYHD = DRD*DSINLS+DRLD*DCOSLS
01018     DYHD = DRD*DSINLS+DRLD*DCOSLS;
01019 
01020 //  PERTL =0.0
01021     PERTL =0.0;
01022 //  PERTLD=0.0
01023     PERTLD=0.0;
01024 //  PERTP =0.0
01025     PERTP =0.0;
01026 //  PERTPD=0.0
01027     PERTPD=0.0;
01028 
01029     //DO 500 K=1,3
01030     for (K = 1; K <= 3; K++) {
01031       //A=DMOD(DCARGM(1,K)+DT*DCARGM(2,K), DC2PI)
01032     A=fmod(DCARGM(1,K)+DT*DCARGM(2,K), DC2PI);
01033 
01034       //SINA  =DSIN(A)
01035     SINA  =sin(A);
01036 
01037       //COSA  =DCOS(A)
01038     COSA  =cos(A);
01039 
01040       //PERTL =PERTL +CCAMPM(1,K)*SINA
01041     PERTL =PERTL +CCAMPM(1,K)*SINA;
01042 
01043       //PERTLD=PERTLD+CCAMPM(2,K)*COSA
01044     PERTLD=PERTLD+CCAMPM(2,K)*COSA;
01045 
01046       //PERTP =PERTP +CCAMPM(3,K)*COSA
01047     PERTP =PERTP +CCAMPM(3,K)*COSA;
01048 
01049       //PERTPD=PERTPD-CCAMPM(4,K)*SINA
01050     PERTPD=PERTPD-CCAMPM(4,K)*SINA;
01051 
01052 //  500 CONTINUE
01053     }
01054     
01055   //TL=FORBEL(2)+PERTL
01056     TL=FORBEL(2)+PERTL;
01057 
01058 //  SINLM=DSIN(TL)
01059     SINLM=sin(TL);
01060 
01061 //  COSLM=DCOS(TL)
01062     COSLM=cos(TL);
01063 
01064 //  SIGMA=CCKM/(1.0+PERTP)
01065     SIGMA=CCKM/(1.0+PERTP);
01066 
01067 //  A=SIGMA*(CCMLD+PERTLD)
01068     A=SIGMA*(CCMLD+PERTLD);
01069 
01070 //  B=SIGMA*PERTPD
01071     B=SIGMA*PERTPD;
01072 
01073 //  DXHD=DXHD+A*SINLM+B*COSLM
01074     DXHD=DXHD+A*SINLM+B*COSLM;
01075 
01076 //  DYHD=DYHD-A*COSLM+B*SINLM
01077     DYHD=DYHD-A*COSLM+B*SINLM;
01078 
01079 //  DZHD=    -SIGMA*CCFDI*DCOS(FORBEL(3))
01080     DZHD=    -SIGMA*CCFDI* cos(FORBEL(3));
01081 
01082 //  DXBD=DXHD*DC1MME
01083     DXBD=DXHD*DC1MME;
01084 
01085 //  DYBD=DYHD*DC1MME
01086     DYBD=DYHD*DC1MME;
01087 //  DZBD=DZHD*DC1MME
01088     DZBD=DZHD*DC1MME;
01089 
01090 //      DO 600 K=1,4
01091     for (K = 1; K <= 4; K++) {
01092 
01093       //PLON=FORBEL(K+3)
01094     PLON=FORBEL(K+3);
01095 
01096       //POMG=SORBEL(K+1)
01097     POMG=SORBEL(K+1);
01098 
01099       //PECC=SORBEL(K+9)
01100     PECC=SORBEL(K+9);
01101 
01102       //TL=DMOD(PLON+2.0*PECC*DSIN(PLON-POMG), CC2PI)
01103     TL=fmod(PLON+2.0*PECC* sin(PLON-POMG), CC2PI);
01104 
01105       //SINLP(K)=DSIN(TL)
01106     SINLP(K)= sin(TL);
01107     
01108       //COSLP(K)=DCOS(TL)
01109     COSLP(K)= cos(TL);
01110 
01111       //DXBD=DXBD+CCPAMV(K)*(SINLP(K)+PECC*DSIN(POMG))
01112     DXBD=DXBD+CCPAMV(K)*(SINLP(K)+PECC*sin(POMG));
01113 
01114       //DYBD=DYBD-CCPAMV(K)*(COSLP(K)+PECC*DCOS(POMG))
01115     DYBD=DYBD-CCPAMV(K)*(COSLP(K)+PECC*cos(POMG));
01116 
01117       //DZBD=DZBD-CCPAMV(K)*SORBEL(K+13)*DCOS(PLON-SORBEL(K+5))
01118     DZBD=DZBD-CCPAMV(K)*SORBEL(K+13)*cos(PLON-SORBEL(K+5));
01119 
01120 //  600 CONTINUE
01121     }
01122     
01123   //DCOSEP=DCOS(DEPS)
01124     DCOSEP=cos(DEPS);
01125   //DSINEP=DSIN(DEPS)
01126     DSINEP=sin(DEPS);
01127   //DYAHD=DCOSEP*DYHD-DSINEP*DZHD
01128     DYAHD=DCOSEP*DYHD-DSINEP*DZHD;
01129   //DZAHD=DSINEP*DYHD+DCOSEP*DZHD
01130     DZAHD=DSINEP*DYHD+DCOSEP*DZHD;
01131   //DYABD=DCOSEP*DYBD-DSINEP*DZBD
01132     DYABD=DCOSEP*DYBD-DSINEP*DZBD;
01133   //DZABD=DSINEP*DYBD+DCOSEP*DZBD
01134     DZABD=DSINEP*DYBD+DCOSEP*DZBD;
01135 
01136   //DVELH(1)=DXHD
01137     DVELH[1]=DXHD;
01138   //DVELH(2)=DYAHD
01139     DVELH[2]=DYAHD;
01140   //DVELH(3)=DZAHD
01141     DVELH[3]=DZAHD;
01142 
01143   //DVELB(1)=DXBD
01144     DVELB[1]=DXBD;
01145   //DVELB(2)=DYABD
01146     DVELB[2]=DYABD;
01147   //DVELB(3)=DZABD
01148     DVELB[3]=DZABD;
01149   //DO 800 N=1,3
01150     for (N = 1; N <= 3; N++) {
01151       //DVELH(N)=DVELH(N)*1.4959787D8
01152     DVELH[N]=DVELH[N]*1.4959787E8;
01153       //DVELB(N)=DVELB(N)*1.4959787D8
01154     DVELB[N]=DVELB[N]*1.4959787E8;
01155 //    800 CONTINUE
01156     }
01157 //      RETURN
01158     return;
01159 }
01160 
01161 /*----------------------------------------------------------------------------*/
01169 /*----------------------------------------------------------------------------*/
01170 
01171 static void
01172 deg2dms(double in_val, 
01173     double *degs,
01174     double *minutes,
01175     double *seconds)
01176 {
01177     deg2hms(in_val*15, degs, minutes, seconds);
01178 }
01179 
01183 #define MIDAS_BUG 0
01184 /*----------------------------------------------------------------------------*/
01192 /*----------------------------------------------------------------------------*/
01193 
01194 static void
01195 deg2hms(double in_val, 
01196     double *hours,
01197     double *minutes,
01198     double *seconds)
01199 {
01200 //    define/parameter p1 ? num "Enter value in deg units"
01201 //    define/local in_val/d/1/1 {p1}
01202 //define/local out_val/c/1/80 " " all
01203 //define/local hours/i/1/1 0
01204 //define/local minutes/i/1/1 0
01205 //define/local seconds/d/1/1 0
01206 
01207 //define/local tmp/d/1/1 0
01208     double tmp;
01209 //define/local hold/c/1/80 " " all
01210 //define/local sign/c/1/1 " "
01211 
01212     char sign;
01213 
01214 //hold = "{in_val}"
01215 //if m$index(hold,"-") .gt. 0 then
01216 //   in_val = m$abs(in_val)
01217 //   sign = "-"
01218 //else
01219 //   sign = "+"
01220 //endif      
01221     if (in_val < 0) {
01222     in_val = fabs(in_val);
01223     sign = '-';
01224     }
01225     else {
01226     sign = '+';
01227     }
01228 
01229 //set/format i1
01231 //  tmp   = in_val / 15
01232     tmp   = in_val / 15;
01233 
01234 //  hours = tmp           !takes the integer part = hours
01235 #if MIDAS_BUG
01236     *hours= uves_round_double(tmp);
01237 #else
01238     *hours= (int) tmp;
01239 #endif
01240 
01241 //  tmp   = tmp - hours   !takes the mantissa 
01242     tmp   = tmp - *hours;
01243 //  tmp   = tmp * 60      !converts the mantissa in minutes
01244     tmp   = tmp * 60;
01245 
01246 //  minutes = tmp         !takes the integer part = minutes
01247 #if MIDAS_BUG
01248     *minutes= uves_round_double(tmp);
01249 #else
01250     *minutes= (int) tmp;
01251 #endif
01252 
01253 //  tmp   = tmp - minutes !takes the mantissa
01254     tmp   = tmp - *minutes;
01255 
01256 //  seconds = tmp * 60      !converts the mantissa in seconds = seconds (with decimal)
01257     *seconds= tmp * 60;
01258 
01259 //out_val = "{sign}{hours},{minutes},{seconds}"
01260 
01261     /* Rather than returning it explicitly, just  attach sign to hours */
01262     if (sign == '-') *hours = -(*hours);
01263 
01264     return;
01265 }
01266 
01269 #if 0   /* Not used / needed.
01270        We simply get the julian date from the input FITS header */
01271 
01272 //      SUBROUTINE JULDAT(INDATE,UTR,JD)
01273 //C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01274 //C
01275 //C.IDENTIFICATION
01276 //C  FORTRAN subroutine                    JULDAT     version 1.0       870102
01277 //C  original coding:                      D. Gillet        ESO - Garching
01278 //C  variables renamed and restructured:   D. Baade         ST-ECF, Garching
01279 //C
01280 //C.KEYWORDS
01281 //C  geocentric Julian date
01282 //C
01283 //C.PURPOSE
01284 //C  calculate geocentric Julian date for any civil date (time in UT)
01285 //C
01286 //C.ALGORITHM
01287 //C adapted from MEEUS J.,1980, ASTRONOMICAL FORMULAE FOR CALCULATORS
01288 //C
01289 //C.INPUT/OUTPUT
01290 //C the following are passed from and to the calling program:
01291 //C  INDATE(3)    :         civil date as year,month,day OR year.fraction
01292 //C  UT           :         universal time expressed in real hours
01293 //C  JD           :         real geocentric Julian date
01294 //C
01295 //C.REVISIONS
01296 //C made to accept also REAL dates         D. Baade             910408
01297 //C
01298 //C-------------------------------------------------------------------------------
01299 //C
01300 
01301 static void 
01302 juldat(double *INDATE,
01303        double UTR,
01304        double *JD)
01305 {
01306 //      DOUBLE PRECISION YP,P,C,A,UT
01307     double UT;
01308 
01309 //      DOUBLE PRECISION UTR,JD
01310 //C
01311 //      INTEGER  STAT,IA,IB,IC,ND,DATE(3)
01312     int DATE[4];
01313 //C
01314 //      REAL    INDATE(3),FRAC
01315 //C
01316 
01317 //  UT=UTR / 24.0D0
01318     UT=UTR / 24.0;
01319 
01320 // CHECK FORMAT OF DATE: may be either year,month,date OR year.fraction,0,0 
01321 // (Note that the fraction of the year must NOT include fractions of a day.)
01322 // For all other formats exit and terminate also calling command sequence.
01323 //
01324 //      IF ((INDATE(1)-INT(INDATE(1))).GT.1.0E-6) THEN 
01325 //         IF ((INDATE(2).GT.1.0E-6).OR.(INDATE(3).GT.1.0E-6)) 
01326 //     +       CALL   STETER(1,'Error: Date was entered in wrong format.')
01327 
01328 // copy date input buffer copy to other buffer so that calling program 
01329 // does not notice any changes
01330 
01331 // FIRST CASE: format was year.fraction
01332 
01333 //         DATE(1)=INT(INDATE(1))
01334 //         FRAC=INDATE(1)-DATE(1)
01335 //         DATE(2)=1
01336 //         DATE(3)=1
01337 //      ELSE
01338 //
01339 // SECOND CASE: format was year,month,day
01340 //
01341 
01342 //       DATE(1)=NINT(INDATE(1))
01343     DATE[1]=uves_round_double(INDATE[1]);
01344 
01345     //FRAC=0
01346     FRAC = 0;
01347 
01348   //DATE(2)=NINT(INDATE(2))
01349     DATE[2]=uves_round_double(INDATE[2]);
01350   //DATE(3)=NINT(INDATE(3))
01351     DATE[3]=uves_round_double(INDATE[3]);
01352 
01353   //IF ((DATE(2).EQ.0).AND.(DATE(3).EQ.0)) THEN
01354     if ((DATE[2] == 0) &&  (DATE[3] == 0)) {
01355        //DATE(2)=1
01356     DATE[2]=1;
01357        //DATE(3)=1
01358     DATE[3]=1;
01359 //    ENDIF
01360     }
01361 
01362 //         IF ((DATE(2).LT.1).OR.(DATE(2).GT.12))
01363 //     +   CALL STETER(1,'Error: such a month does not exist')
01364 //         IF ((DATE(3).LT.1).OR.(DATE(3).GT.31))
01365 //     +   CALL STETER(1,'Error: such a day does not exist')
01366 //      ENDIF
01367 
01368 // from here on, the normal procedure applies which is based on the 
01369 // format year,month,day:
01370 
01371     //IF (DATE(2) .GT. 2) THEN
01372     if (DATE[2] > 2) {
01373       //YP=DATE(1)
01374     YP=DATE[1];
01375       //P=DATE[2]
01376     P=DATE[2];
01377 //    ELSE
01378     } else {
01379       //YP=DATE(1)-1
01380     YP=DATE[1]-1;
01381       //P=DATE(2)+12.0
01382     P=DATE(2)+12.0;
01383 //      ENDIF
01384     }
01385 
01386 //  C = DATE(1) + DATE(2)*1.D-2 + DATE(3)*1.D-4 + UT*1.D-6
01387     C = DATE[1] + DATE[2]*1.E-2 + DATE[3]*1.E-4 + UT*1.E-6;
01388 
01389 //  IF (C .GE. 1582.1015D0) THEN
01390     if (C  >   1582.1015E0) {
01391       //IA=IDINT(YP/100.D0)
01392     IA=(int) (YP/100.D0);
01393       //A=DBLE(IA)
01394     A=IA;
01395       //IB=2-IA+IDINT(A/4.D0)
01396     IB=2-IA+((int)(A/4.D0));
01397       //ELSE
01398     } else {
01399       //IB=0
01400     IB=0;
01401       //ENDIF
01402     }
01403 
01404 //      JD = DINT(365.25D0*YP) + DINT(30.6001D0*(P+1.D0)) + DATE(3) + UT
01405 //     *        + DBLE(IB) + 1720994.5D0
01406     *JD = ((int) (365.25E0*YP)) + ((int)(30.6001D0*(P+1.D0))) + DATE[3] + UT
01407             + IB + 1720994.5E0;
01408 
01409 // finally, take into account fraction of year (if any), respect leap
01410 // year conventions
01411 //
01412 //  IF (FRAC.GT.1.0E-6) THEN
01413     if (FRAC > 1.0E-6) {
01414       //ND=365
01415     ND=365;
01416 
01417       //IF (C.GE.1582.1015D0) THEN
01418     IF (C >= 1582.1015E0) {
01419           //IC = MOD(DATE(1),4)
01420         IC = DATE[1] % 4;
01421           //IF (IC.EQ.0) THEN
01422         if (IC == 0) {
01423           //ND=366
01424         ND=366;
01425           //IC = MOD(DATE(1),100)
01426         IC = DATE[1] % 100;
01427           //IF (IC.EQ.0) THEN
01428         if (IC == 0) {
01429           //IC = MOD(DATE(1),400)
01430             IC = DATE[1] % 400;
01431           //IF (IC.NE.0) ND=365
01432             if (IC != 0) ND=365;
01433           //ENDIF
01434         }
01435         //ENDIF
01436         }
01437         //ENDIF
01438     }
01439 
01440       //IF ( ABS(FRAC*ND-NINT(FRAC*ND)).GT.0.3) THEN
01441     if (fabs(FRAC*ND-uves_round_double(FRAC*ND)) > 0.3) {
01442 //            CALL STTPUT
01443 //     +      ('Warning: Fraction of year MAY not correspond to ',STAT)
01444 //            CALL STTPUT('         integer number of days.',STAT)
01445         uves_msg_warning("Fraction of year MAY not correspond to "
01446                  "integer number of days");
01447 //         ENDIF
01448     }
01449 
01450 //      JD = JD+NINT(FRAC*ND)
01451     *JD = *JD+uves_round_double(FRAC*ND);
01452 //      ENDIF
01453     }
01454 
01455 //      RETURN
01456     return;
01457 }
01458 #endif

Generated on 8 Mar 2011 for UVES Pipeline Reference Manual by  doxygen 1.6.1