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-5_0_0 $ 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