eddy/BTA_lib
1
0
Fork 0
mirror of https://github.com/eddyem/BTA_lib.git synced 2025-12-06 02:35:20 +03:00
Code Issues Packages Projects Releases Wiki Activity

copy

Browse Source
This commit is contained in:
eddyem 2015-10-27 19:46:19 +03:00
parent 0891300939
commit 6b3ca8a34b
221 changed files with 36460 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
LICENSE
View File

@ -1,4 +1,4 @@
GNU GENERAL PUBLIC LICENSE
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
@ -672,4 +672,3 @@ may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
<http://www.gnu.org/philosophy/why-not-lgpl.html>.

24
Makefile Normal file
View File

@ -0,0 +1,24 @@
PROGRAM = bta_control
LDFLAGS = -lcrypt -lm -lsla
SRCS = bta_shdata.c bta_control.c cmdlnopts.c parceargs.c usefull_macros.c ch4run.c
SRCS += angle_functions.c bta_print.c
CC = gcc
DEFINES = -D_XOPEN_SOURCE=666 -DEBUG
#-DEMULATION
CXX = gcc
CFLAGS = -Wall -Werror -Wextra $(DEFINES) -pthread
OBJS = $(SRCS:.c=.o)
all : $(PROGRAM)
$(PROGRAM) : $(OBJS)
$(CC) $(CFLAGS) $(OBJS) $(LDFLAGS) -o $(PROGRAM)
# some addition dependencies
# %.o: %.c
# $(CC) $(LDFLAGS) $(CFLAGS) $< -o $@
#$(SRCS) : %.c : %.h $(INDEPENDENT_HEADERS)
# @touch $@
clean:
/bin/rm -f *.o *~
depend:
$(CXX) -MM $(CXX.SRCS)

1
Readme.md Normal file
View File

@ -0,0 +1 @@
Simple CLI BTA client

270
angle_functions.c Normal file
View File

@ -0,0 +1,270 @@
/*
* angle_functions.c - different functions for angles/times processing in different format
*
* Copyright 2015 Edward V. Emelianov <eddy@sao.ru, edward.emelianoff@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#define _GNU_SOURCE 666 // strcasecmp
#include <assert.h>
#include <math.h>
#include <stdlib.h>
#include <limits.h>
#include <time.h>
#include <string.h>
//#include <slalib.h> // SLA library files in bad format
#include <slamac.h> // SLA macros
#include "cmdlnopts.h"
#include "bta_shdata.h"
#include "angle_functions.h"
#include "usefull_macros.h"
extern void sla_caldj(int*, int*, int*, double*, int*);
extern void sla_amp(double*, double*, double*, double*, double*, double*);
extern void sla_map(double*, double*, double*, double*, double*,double*, double*, double*, double*, double*);
void slacaldj(int y, int m, int d, double *djm, int *j){
int iy = y, im = m, id = d;
sla_caldj(&iy, &im, &id, djm, j);
}
void slaamp(double ra, double da, double date, double eq, double *rm, double *dm ){
double r = ra, d = da, mjd = date, equi = eq;
sla_amp(&r, &d, &mjd, &equi, rm, dm);
}
void slamap(double rm, double dm, double pr, double pd,
double px, double rv, double eq, double date,
double *ra, double *da){
double r = rm, d = dm, p1 = pr, p2 = pd, ppx = px, prv = rv, equi = eq, dd = date;
sla_map(&r, &d, &p1, &p2, &ppx, &prv, &equi, &dd, ra, da);
}
/**
* convert angle in seconds into degrees
* @return angle in range [0..360]
*/
double sec_to_degr(double sec){
double sign = 1.;
if(sec < 0.){
sign = -1.;
sec = -sec;
}
int d = ((int)sec / 3600.);
sec -= ((double)d) * 3600.;
d %= 360;
double angle = sign * (((double)d) + sec / 3600.);
if(angle < 0.) angle += 360.;
return (angle);
}
/**
* Carefull atoi (int32_t)
* @param num (o) - returning value (or NULL if you wish only check number) - allocated by user
* @param str (io) - pointer to string with number must not be NULL (return remain string or NULL if all processed)
* @return TRUE if conversion sone without errors, FALSE otherwise
* ALSO return FALSE (but set num to readed integer) and not modify str if find "." after integer
*/
bool myatoi(int32_t *num, char **str){
long long tmp;
char *endptr;
assert(str);
assert(num);
assert(*str);
*num = 0;
tmp = strtoll(*str, &endptr, 0);
if(endptr == *str || errno == ERANGE)
return FALSE;
if(tmp < INT_MIN || tmp > INT_MAX){
WARNX(_("Integer out of range"));
return FALSE;
}
*num = (int32_t)tmp;
if(endptr && *endptr == '.') return FALSE; // double number
*str = endptr;
return TRUE;
}
// the same as myatoi but for double
bool myatod(double *num, char **str){
double tmp;
char *endptr;
assert(str);
assert(num);
assert(*str);
tmp = strtod(*str, &endptr);
if(endptr == *str || errno == ERANGE)
return FALSE;
*num = tmp;
*str = endptr;
return TRUE;
}
/**
* try to convert first numbers in string into integer or double
* @arg i (o) - readed integer
* @arg d (o) - readed double
* @arg s (io) - string to convert (modified)
* @return 0 in case of error; 1 if number is integer & 2 if number is double
*/
int getIntDbl(int32_t *i, double *d, char **s){
//DBG("str: %s", *s);
int32_t i0; double d0;
if(!myatoi(&i0, s)){ // bad number or double
if(!myatod(&d0, s))
return 0;
*d = d0;
//DBG("got dbl: %g", d0);
return 2;
}
*i = i0;
//DBG("got int: %d", i0);
return 1;
}
/**
* Convert string "[+-][DD][MM'][SS.S'']into degrees
* available formats:
* dd[.d] - degrees
* mm[.m]' - arc minutes
* ss[.s]'' - arc seconds
* dd:mm[.m] - dd degrees & mm minutes
* dd:mm:ss[.s] - dd degrees & mm minutes & ss seconds
* also delimeter can be space, comma or semicolon
*
* @param ang (o) - angle in radians or exit with help message
* @param str (i) - string with angle
* @return NULL if false or str remainder ('\0' if all string processed) if OK
*/
char *get_degrees(double *ret, char *str){
if(!ret || !str){
WARNX(_("Wrong get_radians() argument"));
return NULL;
}
const char delimeters[] = ": ,;";
char *str_ori = str;
double sign = 1., degr = 0., min = 0., sec = 0., d;
int32_t i;
int res;
while(*str){ // check sign & omit leading shit
char c = *str;
if(c > '0'-1 && c < '9'+1) break;
++str;
if(c == '+') break;
if(c == '-'){ sign = -1.; break;}
}
// now check string
res = getIntDbl(&i, &d, &str);
#define assignresult(dst) do{dst = (res == 2) ? fabs(d) : (double)abs(i);}while(0)
if(!res || !str) goto badfmt;
if(*str == 0 || res == 2){ // argument - only one number or double
assignresult(degr);
goto allOK;
}
// we have something else
if(str[0] == '\''){ // one number in format "xx'" or "xx''"
if(str[1] == 0){ // minutes
assignresult(min);
goto allOK;
}else if(str[1] == '\'' && str[2] == 0){ // seconds
assignresult(sec);
goto allOK;
}else goto badfmt;
}
if(strchr(delimeters, (int)*str)){ // dd:mm[:ss]?
assignresult(degr);
if(res == 2) goto allOK; // we get double - next number isn't our
++str;
res = getIntDbl(&i, &d, &str);
if(!res) goto badfmt;
assignresult(min);
if(res == 2) goto allOK;
}else goto badfmt;
if(str && *str){ // there's something remain - ss.ss?
if(!strchr(delimeters, (int)*str)) goto badfmt;
++str;
res = getIntDbl(&i, &d, &str);
if(!res) goto badfmt;
assignresult(sec);
}
#undef assignresult
allOK:
*ret = sign*(degr + min/60. + sec/3600.);
DBG("Got %g:%g:%g = %g", sign*degr, min, sec, *ret);
return str;
badfmt:
WARNX(_("Bad angle format: %s"), str_ori);
return NULL;
}
/**
* Calculate apparent place for given coordinates
* @param r,d (i) - RA/Decl for given epoch (if --epoch given) or for 2000.0
* (RA in hours, Decl in degrees)
* @param appRA, appDecl (o) - calculated apparent place
*/
bool calc_AP(double r, double d, double *appRA, double *appDecl){
double mjd = 51544.5; // mjd2000
// convert to radians
r *= DH2R;
d *= DD2R;
double ra2000 = r, decl2000 = d; // coordinates for 2000.0
const double jd0 = 2400000.5; // JD for MJD==0
// epoch given - calculate it
if(GP->epoch){
DBG("Epoch: %s", GP->epoch);
char *str = GP->epoch;
if(strcasecmp(str, "now") == 0 || strcmp(str, "1") == 0){ // now
mjd = JDate - jd0;
}else{ // check given data
double year, add = 0.;
int y, m, d, err;
if(!myatod(&year, &str)) goto baddate;
if(fabs(year - ((int)year)) < 0.001){
y = (int)year; m = 1; d = 1;
}else{
time_t t = (year - 1970.) * 31557600.0; // date in UNIX time format
struct tm tms;
if(!gmtime_r(&t, &tms)) goto baddate;
y = 1900 + tms.tm_year;
m = tms.tm_mon + 1;
d = tms.tm_mday;
add = ((double)tms.tm_hour + (double)tms.tm_min/60.0 + tms.tm_sec/3600.0) / 24.;
}
slacaldj(y, m, d, &mjd, &err);
if(err){
WARNX(_("slacaldj(): Wrong %s!"), (err == 1) ? "year" :
(err == 2? "month" : "day"));
return FALSE;
}
mjd += add;
}
DBG("slaamp(%g, %g, %g, 2000.0, ra, dec)", r,d,mjd);
slaamp(r, d, mjd, 2000.0, &ra2000, &decl2000);
DBG("2000: %g, %g", ra2000*DR2H, decl2000*DR2D);
}
// proper motion on R.A./Decl (mas/year)
double pmra = GP->pmra/1000.*DAS2R, pmdecl = GP->pmdecl/1000.*DAS2R;
mjd = JDate - jd0;
slamap(ra2000, decl2000, pmra, pmdecl, 0., 0., 2000.0, mjd, &r, &d);
DBG("APP: %g, %g", r*DR2H, d*DR2D);
r *= DR2S;
d *= DR2AS;
if(appRA) *appRA = r;
if(appDecl) *appDecl = d;
return TRUE;
baddate:
WARNX(_("Epoch should be \"now\" (or omit) or Julian year (don't use this arg for 2000.0)"));
return FALSE;
}

41
angle_functions.h Normal file
View File

@ -0,0 +1,41 @@
/*
* angle_functions.h
*
* Copyright 2015 Edward V. Emelianov <eddy@sao.ru, edward.emelianoff@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#pragma once
#ifndef __ANGLE_FUNCTIONS_H__
#define __ANGLE_FUNCTIONS_H__
#include <stdbool.h>
#ifndef TRUE
#define TRUE true
#endif
#ifndef FALSE
#define FALSE false
#endif
double sec_to_degr(double sec);
char *get_degrees(double *ret, char *str);
bool calc_AP(double r, double d, double *appRA, double *appDecl);
bool myatod(double *num, char **str);
bool myatoi(int32_t *num, char **str);
#endif // __ANGLE_FUNCTIONS_H__

712
bta_control.c Normal file
View File

@ -0,0 +1,712 @@
/*
* bta_control.c
*
* Copyright 2015 Edward V. Emelianov <eddy@sao.ru, edward.emelianoff@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#define _GNU_SOURCE 666 // for strcasestr
#include <assert.h>
#include <signal.h>
#include <strings.h>
#include <string.h>
#include <pthread.h>
#include <math.h>
#include "bta_shdata.h"
#include "cmdlnopts.h"
#include "usefull_macros.h"
#include "ch4run.h"
#include "bta_control.h"
#include "angle_functions.h"
#include "bta_print.h"
#ifndef PIDFILE
#define PIDFILE "/tmp/bta_control.pid"
#endif
// constants for choosing move/goto (move for near objects)
const double Amove = 1800.; // +-30'
const double Zmove = 3600.; // +-60'
// arcseconds to radians
#define AS2R (M_PI/180./3600.)
glob_pars *GP = NULL;
#define PRINT(...) do{if(!GP->quiet) printf(__VA_ARGS__);}while(0)
// ACS command wrapper
#ifdef EMULATION
#define ACS_CMD(a) do{green(#a); printf("\n");}while(0)
#else
#define ACS_CMD(a) do{red(#a); printf("\n");}while(0)
// Uncomment only in final release
// #define ACS_CMD(a) do{DBG(#a "\n"); a; }while(0)
#endif
#ifndef EMULATION
typedef struct{
uint32_t keylev;
uint32_t codelev;
} passhash;
#endif
void signals(int sig){
if(sig)
WARNX(_("Get signal %d, quit.\n"), sig);
else
sig = -1;
unlink(PIDFILE);
restore_console();
exit(sig);
}
volatile int tmout = 0;
pthread_t athread;
void *tmout_thread(void *buf){
int selfd = -1, *sec = (int*)buf;
struct timeval tv;
tv.tv_sec = *sec;
tv.tv_usec = 0;
errno = 0;
while(selfd < 0){
selfd = select(0, NULL, NULL, NULL, &tv);
if(selfd < 0 && errno != EINTR){
WARN(_("Error while select()"));
tmout = 1;
return NULL;
}
}
tmout = 1;
return NULL;
}
/**
* run thread with pause [delay] (in seconds), at its end set variable tmout
*/
void set_timeout(int delay){
static int run = 0;
static int *arg = NULL;
if(!arg) arg = MALLOC(int, 1);
if(run && (pthread_kill(athread, 0) != ESRCH)){ // another timeout process detected - kill it
pthread_cancel(athread);
pthread_join(athread, NULL);
}
tmout = 0;
run = 1;
*arg = delay;
if(pthread_create(&athread, NULL, tmout_thread, (void*)arg)){
WARN(_("Can't create timeout thread!"));
tmout = 1;
return;
}
;
}
char indi[] = "|/-\\";
char *iptr = indi;
#define WAIT_EVENT(evt, max_delay) do{int __ = 0; set_timeout(max_delay); \
PRINT(" "); while(!tmout && !evt){\
usleep(100000); if(!*(++iptr)) iptr = indi; if(++__%10==0) PRINT("\b. "); \
PRINT("\b%c", *iptr);}; PRINT("\n");}while(0)
#ifndef EMULATION
void get_passhash(passhash *p){
int fd = -1, i, c, nlev = 0;
char *filename = GP->passfile;
if(filename){ // user give filename with [stored?] hash
struct stat statbuf;
if((fd = open(filename, O_RDWR | O_CREAT, S_IRUSR | S_IWUSR)) < 0)
ERR(_("Can't open %s for reading"), filename);
if(fstat (fd, &statbuf) < 0)
ERR(_("Can't stat %s"), filename);
if(!S_ISREG(statbuf.st_mode))
ERR(_("%s is not regular file"), filename);
if(statbuf.st_mode != (S_IRUSR | S_IWUSR)){ // wrong mode
if(chmod(filename, S_IRUSR | S_IWUSR))
ERR(_("Can't change permissions of %s to 0600"), filename);
}
if(8 == read(fd, p, 8)){ // check password, if it is good, return
for(i = 5; i > 0; --i){
if(p->codelev == code_Lev(i)) break;
}
if(i){
set_acckey(p->keylev);
close(fd);
return;
}
}
}
// ask user to enter password
setup_con(); // hide echo
for(i = 3; i > 0; --i){ // try 3 times
char pass[256]; int k = 0;
printf("Enter password, you have %d tr%s\n", i, (i > 1) ? "ies":"y");
while ((c = mygetchar()) != '\n' && c != EOF && k < 255){
if(c == '\b' || c == 127){ // use DEL and BACKSPACE to erase previous symbol
if(k) --k;
printf("\b \b");
}else{
pass[k++] = c;
printf("*");
}
fflush(stdout);
}
pass[k] = 0;
printf("\n");
if((nlev = find_lev_passwd(pass, &p->keylev, &p->codelev)))
break;
printf(_("No, not this\n"));
}
restore_console();
if(nlev == 0)
ERRX(_("Tries excess!"));
set_acckey(p->keylev);
DBG("OK, level %d", nlev);
if(fd > 0){
PRINT(_("Store\n"));
if(0 != lseek(fd, 0, SEEK_SET)){
WARN(_("Can't seek to start of %s"), filename);
}else if(8 != write(fd, p, 8))
WARN(_("Can't store password hash in %s"), filename);
close(fd);
}
}
#endif // EMULATION
/***************************************************************
* All functions for changing telescope parameters are boolean *
* returning TRUE in case of succsess or FALSE if failed *
***************************************************************/
/**
* move P2 to the given angle relative to current position +- P2_ANGLE_THRES
*/
void cmd_P2moveto(double p2shift){
double p2vel = 45.*60., p2dt, p2mintime = 4.5, p2secs = fabs(p2shift) * 3600.;
if(fabs(p2shift) < P2_ANGLE_THRES) return;
p2dt = p2secs / p2vel;
if(p2dt < p2mintime){
p2vel = p2secs / p2mintime;
if(p2vel < 1.) p2vel = 1;
p2dt = p2secs / p2vel;
}
if(p2shift < 0) p2vel = -p2vel;
DBG("p2vel=%g, p2dt = %g", p2vel, p2dt);
ACS_CMD(MoveP2To(p2vel, p2dt));
#ifndef EMULATION
PRINT(_("Moving P2 "));
// wait until P2 stops, set to guiding or timeout ends
WAIT_EVENT(((fabs(vel_P) < 1.) || (P2_State == P2_On)), p2dt + 1.);
if(tmout && P2_State != P2_Off){
WARNX(_("Timeout reached, stop P2"));
ACS_CMD(MoveP2(0));
}
#endif
}
/**
* move P2 to given angle or at given delta
* @param angle angle to move (in degrees) with suffix "rel" for relative moving
*/
bool moveP2(char *arg){
if(!arg) return FALSE;
int p2rel = 0;
char *eptr = NULL;
int badarg = 0;
if((eptr = strcasestr(arg, "rel"))){
if(eptr == arg){
badarg = 1;
goto bdrg;
}else{
if(eptr[-1] < '0' || eptr[-1] > '9') eptr[-1] = 0; // omit last non-number
else *eptr = 0;
eptr = NULL;
p2rel = 1;
}
}
double p2angle;
if(!get_degrees(&p2angle, arg)) badarg = 1;
else{ // now check if there a good angle
if(p2angle < -360. || p2angle > 360.) badarg = 1;
else if(eptr){
if(strcasecmp(eptr, "rel") == 0)
p2rel = 1;
else // wrong degrees format
badarg = 1;
}
}
bdrg:
if(badarg){
WARNX(_("Key p2move should be in format angle[rel],\n\tangle - from -360 to +360"
"\n\twrite \"rel\" after angle for relative moving"));
return FALSE;
}
// now get information about current angle & check target angle
double p2val = sec_to_degr(val_P);
DBG("p2 now is at %g", p2val);
if(p2rel) p2angle += p2val;
if(p2angle < 0.) p2angle += 360.;
else if(p2angle > 360.) p2angle -= 360.;
if(p2angle > P2_LOW_ES && p2angle < P2_HIGH_ES){ // prohibited angle
WARNX(_("Target angle (%g) is in prohibited zone (between %g & %g degrees)"),
p2angle, P2_LOW_ES, P2_HIGH_ES);
return FALSE;
}
if(P2_State != P2_Off && P2_State != P2_On){
WARNX(_("P2 is already moving!"));
if(!GP->force) return FALSE;
WARNX(_("Force stop"));
ACS_CMD(MoveP2(0)); // stop P2
#ifndef EMULATION
if(P2_State != P2_Off){
PRINT(_("Wait for P2 stop "));
WAIT_EVENT(P2_State == P2_Off, 5);
if(tmout && P2_State != P2_Off){
WARNX(_("Timeout reached, can't stop P2"));
return 0;
}
}
#endif
}
DBG("Move P2 to %gdegr", p2angle);
if(fabs(p2angle - p2val) < P2_ANGLE_THRES){
WARNX(_("Zero moving (< %g)"), P2_ANGLE_THRES);
return TRUE;
}
int i;
for(i = 0; i < 3; ++i){
if(i) PRINT(_("Try %d. "), i+1);
cmd_P2moveto(p2angle - p2val);
p2val = sec_to_degr(val_P);
if(fabs(p2angle - p2val) < P2_ANGLE_THRES) break;
}
if(fabs(p2angle - p2val) > P2_ANGLE_THRES){
WARNX(_("Error moving P2: have %gdegr, need %gdegr"), p2val, p2angle);
return FALSE;
}
return TRUE;
}
/**
* set P2 mode: stop or track
*/
bool setP2mode(char *arg){
int _U_ mode;
if(!arg) goto badarg;
if(strcasecmp(arg, "stop") == 0) mode = P2_Off;
else if(strcasecmp(arg, "track") == 0) mode = P2_On;
else goto badarg;
DBG("Set P2 mode to %s", (mode == P2_Off) ? "stop" : "track");
ACS_CMD(SetPMode(mode));
#ifndef EMULATION
if(P2_State != mode){
PRINT(_("Wait for given mode "));
WAIT_EVENT(P2_State == mode, 5);
if(tmout && P2_State != mode){
WARNX(_("Timeout reached, can't set P2 mode"));
return FALSE;
}
}
#endif
return TRUE;
badarg:
WARNX(_("Parameter should be \"stop\" or \"track\""));
return FALSE;
}
void cmd_Fmoveto(double f){
const double FOC_HVEL = 0.63, FOC_LVEL = 0.13;
int _U_ fspeed;
if(f < 1. || f > 199.) return;
double fshift = f - val_F, fvel, _U_ fdt;
if(fabs(fshift) > 1.){
fvel = FOC_HVEL;
fspeed = (fshift > 0) ? Foc_Hplus : Foc_Hminus;
}else if(fabs(fshift) > 0.05){
fvel = FOC_LVEL;
fspeed = (fshift > 0) ? Foc_Lplus : Foc_Lminus;
} else{
WARNX(_("Can't move for such small distance (%gmm)"), fshift);
return;
}
fdt = fabs(fshift) / fvel;
ACS_CMD(MoveFocus(fspeed, fdt));
#ifndef EMULATION
PRINT(_("Moving Focus "));
WAIT_EVENT((fabs(vel_F) < 0.01 || Foc_State == Foc_Off), fdt + 1.);
if(tmout && Foc_State != Foc_Off){
WARNX(_("Timeout reached, stop focus"));
ACS_CMD(MoveFocus(Foc_Off, 0.));
}
#endif
}
/**
* move focus to given position
*/
bool moveFocus(double val){
if(val < 1. || val > 199.){
WARNX(_("Focus value should be between 1mm & 199mm"));
return FALSE;
}
if(Foc_State != Foc_Off){
WARNX(_("Focus is already moving!"));
if(!GP->force) return FALSE;
WARNX(_("Force stop"));
ACS_CMD(MoveFocus(Foc_Off, 0.));
}
#ifndef EMULATION
if(Foc_State != Foc_Off){
PRINT(_("Wait for focus stop "));
WAIT_EVENT(Foc_State == Foc_Off, 3);
if(tmout && Foc_State != Foc_Off){
WARNX(_("Timeout reached, can't stop focus motor"));
return FALSE;
}
}
#endif
DBG("Move focus to %g", val);
if(fabs(val - val_F) < FOCUS_THRES){
WARNX(_("Zero moving (< %g)"), FOCUS_THRES);
return TRUE;
}
int i;
for(i = 0; i < 3; ++i){
if(i) PRINT(_("Try %d. "), i+1);
cmd_Fmoveto(val);
if(fabs(val - val_F) < FOCUS_THRES) break;
}
if(fabs(val - val_F) > FOCUS_THRES){
WARNX(_("Error moving focus: have %gmm, need %gmm"), val_F, val);
return FALSE;
}
return TRUE;
}
/**
* set new equatorial/horizontal coordinates
* @param coordinates: both RA&Decl/A&Z with any delimeter
* format RA: hh[delimeter]mm[delimeter]ss.s - suitable for get_degrees() but in hours
* format DECL: suitable for get_degrees() but with prefix +/- if goes first
* format A/Z: suitable for get_degrees(), AZIMUTH GOES FIRST!
* @param isEQ: TRUE if equatorial coordinates, FALSE if horizontal
*/
bool setCoords(char *coords, bool isEQ){
if(!coords) return FALSE;
char *ra = NULL, *dec = NULL, *ptr = coords;
double r, d;
if(isEQ){
// find RA & DEC parameters in string
// 1. find first number or +/-
while(*ptr){
char p = *ptr;
if(p > '0'-1 && p < '9'+1){
ra = ptr;
break;
}
else if(p == '+' || p == '-'){
dec = ptr;
break;
}
++ptr;
}
}else ra = ptr;
if(!*ptr || (!ra && !dec /*WTF?*/)) goto badcrds;
if(ra){ // first was RA/AZ
dec = get_degrees(&r, ra);
if(!dec || !*dec || !(ptr = get_degrees(&d, dec))) goto badcrds;
if(*ptr) goto badcrds; // something after last number
}else{ // first was Decl
ra = get_degrees(&d, dec);
if(!ra || !*ra || !(ptr = get_degrees(&r, ra))) goto badcrds;
if(*ptr) goto badcrds;
}
if(isEQ){ // RA/Decl
if(r < 0. || r > 24. || d > 90. || d < -90.) goto badcrds;
double appRA, appDecl;
// calculate apparent place according to other cmdline arguments
if(!calc_AP(r, d, &appRA, &appDecl)) goto badcrds;
DBG("Set RA/Decl to %g, %g", appRA/3600, appDecl/3600);
ACS_CMD(SetRADec(appRA, appDecl));
#ifndef EMULATION
if(InpAlpha != r || InpDelta != d){
PRINT(_("Wait for command result"));
WAIT_EVENT((InpAlpha == r && InpDelta == d), 3);
if(InpAlpha != r || InpDelta != d){
WARNX(_("Can't send data to system!"));
return FALSE;
}
}
#endif
}else{ // A/Z: r==A, d==Z
if(r < -360. || r > 360. || d < 0. || d > 90.) goto badcrds;
// convert A/Z into arcsec
r *= 3600;
d *= 3600;
DBG("Set A/Z to %g, %g", r/3600, d/3600);
ACS_CMD(SetAzimZ(r, d));
#ifndef EMULATION
if(InpAzim != r || InpZdist != d){
PRINT(_("Wait for command result"));
WAIT_EVENT((InpAzim == r && InpZdist == d), 3);
if(InpAzim != r || InpZdist != d){
WARNX(_("Can't send data to system!"));
return FALSE;
}
}
#endif
}
return TRUE;
badcrds:
if(isEQ)
WARNX(_("Wrong coordinates: \"%s\"; should be \"hh mm ss.ss +/-dd mm ss.ss\" (any order)"), coords);
else
WARNX(_("Wrong coordinates: \"%s\"; should be \"[+/-]dd mm ss.ss dd mm ss.ss\" (Az first)"), coords);
return FALSE;
}
/**
* reverce Azimuth traveling
*/
bool azreverce(){
bool ret = TRUE;
int mode = Az_Mode;
if(mode == Rev_Off) mode = Rev_On;
else mode = Rev_On;
ACS_CMD(SetAzRevers(mode));
PRINT(_("Turn %s azimuth reverce "), (mode == Rev_Off) ? "off" : "on");
#ifndef EMULATION
WAIT_EVENT((Az_Mode == mode), 3);
if(Az_Mode != mode) ret = FALSE;
#endif
return ret;
}
bool testauto(){
if(Tel_Mode != Automatic){
WARNX(_("Can't stop telescope: not automatic mode!"));
return FALSE;
}
return TRUE;
}
bool stop_telescope(){
if(!testauto()) return FALSE;
if(Sys_Mode == SysStop){
WARNX(_("Already stoped"));
return TRUE;
}
ACS_CMD(StopTeleskope());
WAIT_EVENT((Sys_Mode == SysStop), 3);
if(Tel_Mode != SysStop){
WARNX(_("Can't stop telescope"));
return FALSE;
}
return TRUE;
}
/**
* move telecope to object by entered coordinates
*/
bool gotopos(bool isradec){
if(!testauto()) return FALSE;
if(Sys_Mode != SysStop && !stop_telescope()) return FALSE;
if(isradec){
if((fabs(val_A - InpAzim) < Amove && fabs(val_Z - InpZdist) < Zmove)){ // move back to last coords
ACS_CMD(MoveToObject());
}else{
ACS_CMD(GoToObject());
}
ACS_CMD(SetSysTarg(TagObject));
}else{
ACS_CMD(GoToAzimZ());
ACS_CMD(SetSysTarg(TagPosition));
}
DBG("start");
usleep(500000);
ACS_CMD(StartTeleskope());
#ifndef EMULATION
PRINT("Go");
WAIT_EVENT((Sys_Mode != SysStop && Sys_Mode != SysWait), 5);
if(tmout){
WARNX(_("Can't move telescope"));
return FALSE;
}
PRINT("Wait for tracking");
// Wait with timeout 15min
WAIT_EVENT((Sys_Mode == SysTrkOk), 900);
if(tmout){
WARNX(_("Eror during telescope pointing"));
return FALSE;
}
#endif
return TRUE;
}
/**
* set PCS state (TRUE == on)
*/
bool PCS_state(bool on){
int _U_ newstate = PC_Off;
if(on){
if(Pos_Corr == PC_On) return TRUE;
ACS_CMD(SwitchPosCorr(PC_On));
newstate = PC_On;
}else{
if(Pos_Corr == PC_Off) return TRUE;
ACS_CMD(SwitchPosCorr(PC_Off));
}
#ifndef EMULATION
WAIT_EVENT((Pos_Corr == newstate), 3);
if(tmout){
WARNX(_("Can't set new PCS state"));
return FALSE;
}
#endif
return TRUE;
}
/**
* make small position correction for angles dx, dy (in arcseconds)
* format: "dx,dy" with any 1-char delimeter
* if isAZ == TRUE, dx is dA, dy is dZ
* else dx is dRA, dy is dDecl
*/
bool run_correction(char *dxdy, bool isAZ){
double dx, dy;
char *eptr = dxdy;
if(!myatod(&dx, &eptr) || !*eptr || !*(++eptr)) goto badang;
if(!myatod(&dy, &eptr)) goto badang;
DBG("dx: %g, dy: %g", dx, dy);
if(!testauto() || dx > CORR_MAX_ANGLE || dy > CORR_MAX_ANGLE) return FALSE;
if(isAZ){
#ifndef EMULATION
double targA = val_A+dx, targZ = val_Z+dy;
#endif
ACS_CMD(DoAZcorr(dx / sin(val_Z * AS2R), dy));// transform dA to "telescope coordinates"
#ifndef EMULATION
WAIT_EVENT((fabs(val_A - targA) < CORR_THRES && fabs(val_Z - targZ) < CORR_THRES), 10);
#endif
}else{
#ifndef EMULATION
double targA = val_Alp+dx, targD = val_Del+dy;
#endif
ACS_CMD(DoADcorr(dx, dy));
#ifndef EMULATION
WAIT_EVENT((fabs(val_Alp - targA) < CORR_THRES && fabs(val_Del - targD) < CORR_THRES), 10);
#endif
}
#ifndef EMULATION
if(tmout){
WARNX(_("Can't do correction (or angle is too large)"));
return FALSE;
}
#endif
return TRUE;
badang:
WARNX(_("Bad format, need \"dx,dy\" in arcseconds"));
return FALSE;
}
int main(int argc, char **argv){
check4running(argv, PIDFILE, NULL);
int retcode = 0;
initial_setup();
info_level showinfo = NO_INFO;
#ifndef EMULATION
passhash pass = {0,0};
#endif
int needblock = 0, needqueue = 0;
GP = parce_args(argc, argv);
assert(GP);
signal(SIGTERM, signals); // kill (-15) - quit
signal(SIGHUP, signals); // hup - quit
signal(SIGINT, signals); // ctrl+C - quit
signal(SIGQUIT, signals); // ctrl+\ - quit
signal(SIGTSTP, SIG_IGN); // ignore ctrl+Z
setbuf(stdout, NULL);
if(GP->getinfo){
needblock = 1;
char *infostr = GP->getinfo;
if(strcmp(infostr, "1") == 0){ // show ALL args
showinfo = ALL_INFO;
}else{
showinfo = get_infolevel(infostr);
}
}
if(showinfo == NO_INFO){
if(GP->infoargs){
showinfo = REQUESTED_LIST;
needblock = 1;
}else if(GP->getinfo) show_infolevels();
}
if(GP->p2move || GP->p2mode || GP->focmove > 0. || GP->eqcrds || GP->horcrds
|| GP->azrev || GP->telstop || GP->gotoRaDec || GP->gotoAZ || GP->PCSoff
|| GP->corrAZ || GP->corrRAD){
needqueue = 1;
}
if(needqueue){
needblock = 1;
}
if(needblock){
if(!get_shm_block(&sdat, ClientSide))
ERRX(_("Can't find shared memory block"));
}
if(needqueue) get_cmd_queue(&ucmd, ClientSide);
if(needblock){
if(!check_shm_block(&sdat))
ERRX(_("There's no connection to BTA!"));
#ifndef EMULATION
double last = M_time;
PRINT(_("Test multicast connection\n"));
WAIT_EVENT((fabs(M_time - last) > 0.02), 5);
if(tmout)
ERRX(_("Multicasts stale!"));
if(needqueue) get_passhash(&pass);
#endif
}
if(showinfo != NO_INFO) bta_print(showinfo, GP->infoargs);
else if(GP->listinfo) bta_print(NO_INFO, NULL); // show arguments available
#define RUN(arg) do{if(!arg) retcode = 1;}while(0)
#define RUNBLK(arg) do{if(!arg) return 1;}while(0)
if(GP->telstop) RUN(stop_telescope());
if(GP->eqcrds) RUNBLK(setCoords(GP->eqcrds, TRUE));
else if(GP->horcrds) RUNBLK(setCoords(GP->horcrds, FALSE));
if(GP->p2move) RUN(moveP2(GP->p2move));
if(GP->p2mode) RUN(setP2mode(GP->p2mode));
if(GP->focmove > 0.) RUN(moveFocus(GP->focmove));
if(GP->azrev) RUN(azreverce());
if(GP->PCSoff) RUNBLK(PCS_state(FALSE));
else if(needqueue) RUNBLK(PCS_state(TRUE));
if(GP->gotoRaDec) RUNBLK(gotopos(TRUE));
else if(GP->gotoAZ) RUNBLK(gotopos(FALSE));
else if(GP->corrAZ) RUN(run_correction(GP->corrAZ, TRUE));
else if(GP->corrRAD) RUN(run_correction(GP->corrRAD, FALSE));
#undef RUN
#undef RUNBLK
unlink(PIDFILE);
restore_console();
return retcode;
}
/*
* Добавить:
* коррекция положения по A/Z или RA/Dec
*/

36
bta_control.h Normal file
View File

@ -0,0 +1,36 @@
/*
* bta_control.h - main definitions
*
* Copyright 2015 Edward V. Emelianov <eddy@sao.ru, edward.emelianoff@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#pragma once
#ifndef __BTA_CONTROL_H__
#define __BTA_CONTROL_H__
// end-switches position (in degr); prohibited angles are in range [P2_LOW_ES .. P2_HIGH_ES]
#define P2_LOW_ES (21.0)
#define P2_HIGH_ES (90.0)
// angle threshold (for p2 move) in degrees
#define P2_ANGLE_THRES (0.01)
#define FOCUS_THRES (0.01)
// max angles for correction of telescope (5' = 300'')
#define CORR_MAX_ANGLE (300)
// correction threshold
#define CORR_THRES (0.1)
#endif // __BTA_CONTROL_H__

744
bta_print.c Normal file
View File

@ -0,0 +1,744 @@
/* Print some BTA NewACS data (or write to file)
*
* copyright: Vladimir Shergin <vsher@sao.ru>
*
* Usage:
* bta_print [time_step] [file_name]
* Where:
* time_step - writing period in sec., >=1.0
* <1.0 - once and exit (default)
* file_name - name of file to write to,
* "-" - stdout (default)
*/
/*
* bta_print.c
*
* Copyright 2015 Edward V. Emelianov <eddy@sao.ru, edward.emelianoff@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
/**
* Modified by E.E. as part of common BTA ACS management system
*/
#ifndef _GNU_SOURCE
#define _GNU_SOURCE
#endif
#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <errno.h>
#include <math.h>
#include <string.h>
#include <signal.h>
#include <time.h>
#include <sys/time.h>
#include <sys/types.h>
#include <sys/times.h>
#include <ctype.h>
#include <crypt.h>
#include "bta_shdata.h"
#include "bta_print.h"
#include "usefull_macros.h"
#define BUFSZ 255
static char buf[BUFSZ+1];
typedef struct{
const char *name;
const info_level lvl;
}levelstr;
const levelstr const infolevels_str[] = {
{"coordinates", BASIC_COORDS},
{"coords", BASIC_COORDS},
{"extcrds", EXTENDED_COORDS},
{"morecrds", EXTENDED_COORDS},
{"meteo", METEO_INFO},
{"time", TIME_INFO},
{"acs", ACS_INFO},
{"system", ACS_INFO},
{NULL, NO_INFO}
};
typedef struct{
const char *name;
const int pos_idx;
}parstr;
// ./btatest -l|awk "{print \"\tPAR_\"\$1\",\" }"
typedef enum{
PAR_M_time,
PAR_S_time,
PAR_JDate,
PAR_Tel_Mode,
PAR_Tel_Focus,
PAR_Tel_Taget,
PAR_P2_Mode,
PAR_PCS_Coeffs,
PAR_code_KOST,
PAR_Az_Reverce,
PAR_Az_EndSw,
PAR_Zen_EndSw,
PAR_P2_EndSw,
PAR_Worm_A,
PAR_Worm_Z,
PAR_Lock_Flags,
PAR_Oil_Pres,
PAR_Oil_Temp,
PAR_Oil_Cool_Temp,
PAR_CurAlpha,
PAR_CurDelta,
PAR_SrcAlpha,
PAR_SrcDelta,
PAR_InpAlpha,
PAR_InpDelta,
PAR_CurAzim,
PAR_CurZenD,
PAR_InpAzim,
PAR_InpZenD,
PAR_CurPA,
PAR_SrcPA,
PAR_InpPA,
PAR_TelPA,
PAR_ValFoc,
PAR_ValAzim,
PAR_ValZenD,
PAR_ValP2,
PAR_ValDome,
PAR_DiffAzim,
PAR_DiffZenD,
PAR_DiffP2,
PAR_DiffDome,
PAR_VelAzim,
PAR_VelZenD,
PAR_VelP2,
PAR_VelPA,
PAR_VelDome,
PAR_CorrPCS,
PAR_Refraction,
PAR_CorrAlpha,
PAR_CorrDelta,
PAR_CorrAzim,
PAR_CorrZenD,
PAR_Foc_State,
PAR_ValTout,
PAR_ValTind,
PAR_ValTmir,
PAR_ValPres,
PAR_ValWind,
PAR_Blast10,
PAR_Blast15,
PAR_Precipitation,
PAR_ValHumd,
PAR_bta_pars_end
}bta_pars;
uint8_t parameters_to_show[PAR_bta_pars_end] = {0};
// ./btatest -l|awk "{print \"\t\{\\\"\"\$1\"\\\", PAR_\"\$1\"\},\" }"
const parstr const parameters_str[] = {
{"M_time", PAR_M_time},
{"S_time", PAR_S_time},
{"JDate", PAR_JDate},
{"Tel_Mode", PAR_Tel_Mode},
{"Tel_Focus", PAR_Tel_Focus},
{"Tel_Taget", PAR_Tel_Taget},
{"P2_Mode", PAR_P2_Mode},
{"PCS_Coeffs", PAR_PCS_Coeffs},
{"code_KOST", PAR_code_KOST},
{"Az_Reverce", PAR_Az_Reverce},
{"Az_EndSw", PAR_Az_EndSw},
{"Zen_EndSw", PAR_Zen_EndSw},
{"P2_EndSw", PAR_P2_EndSw},
{"Worm_A", PAR_Worm_A},
{"Worm_Z", PAR_Worm_Z},
{"Lock_Flags", PAR_Lock_Flags},
{"Oil_Pres", PAR_Oil_Pres},
{"Oil_Temp", PAR_Oil_Temp},
{"Oil_Cool_Temp", PAR_Oil_Cool_Temp},
{"CurAlpha", PAR_CurAlpha},
{"CurDelta", PAR_CurDelta},
{"SrcAlpha", PAR_SrcAlpha},
{"SrcDelta", PAR_SrcDelta},
{"InpAlpha", PAR_InpAlpha},
{"InpDelta", PAR_InpDelta},
{"CurAzim", PAR_CurAzim},
{"CurZenD", PAR_CurZenD},
{"InpAzim", PAR_InpAzim},
{"InpZenD", PAR_InpZenD},
{"CurPA", PAR_CurPA},
{"SrcPA", PAR_SrcPA},
{"InpPA", PAR_InpPA},
{"TelPA", PAR_TelPA},
{"ValFoc", PAR_ValFoc},
{"ValAzim", PAR_ValAzim},
{"ValZenD", PAR_ValZenD},
{"ValP2", PAR_ValP2},
{"ValDome", PAR_ValDome},
{"DiffAzim", PAR_DiffAzim},
{"DiffZenD", PAR_DiffZenD},
{"DiffP2", PAR_DiffP2},
{"DiffDome", PAR_DiffDome},
{"VelAzim", PAR_VelAzim},
{"VelZenD", PAR_VelZenD},
{"VelP2", PAR_VelP2},
{"VelPA", PAR_VelPA},
{"VelDome", PAR_VelDome},
{"CorrPCS", PAR_CorrPCS},
{"Refraction", PAR_Refraction},
{"CorrAlpha", PAR_CorrAlpha},
{"CorrDelta", PAR_CorrDelta},
{"CorrAzim", PAR_CorrAzim},
{"CorrZenD", PAR_CorrZenD},
{"Foc_State", PAR_Foc_State},
{"ValTout", PAR_ValTout},
{"ValTind", PAR_ValTind},
{"ValTmir", PAR_ValTmir},
{"ValPres", PAR_ValPres},
{"ValWind", PAR_ValWind},
{"Blast10", PAR_Blast10},
{"Blast15", PAR_Blast15},
{"Precipitation", PAR_Precipitation},
{"ValHumd", PAR_ValHumd},
{NULL, 0}
};
char *time_asc(double t){
int h, min;
double sec;
h = (int)(t/3600.);
min = (int)((t - (double)h*3600.)/60.);
sec = t - (double)h*3600. - (double)min*60.;
h %= 24;
if(sec>59.99) sec=59.99;
snprintf(buf, BUFSZ, "%02d:%02d:%05.2f", h,min,sec);
return buf;
}
char *angle_asc(double a){
char s;
int d, min;
double sec;
if (a >= 0.)
s = '+';
else {
s = '-'; a = -a;
}
d = (int)(a/3600.);
min = (int)((a - (double)d*3600.)/60.);
sec = a - (double)d*3600. - (double)min*60.;
d %= 360;
if(sec>59.9) sec=59.9;
snprintf (buf, BUFSZ, "%c%02d:%02d:%04.1f", s,d,min,sec);
return buf;
}
char *angle_fmt(double a, char *format){
char s, *p;
int d, min, n;
double sec, msec;
char *newformat = MALLOC(char, strlen(format) + 3);
sprintf(newformat, "%s", format);
if (a >= 0.)
s = '+';
else {
s = '-'; a = -a;
}
d = (int)(a/3600.);
min = (int)((a - (double)d*3600.)/60.);
sec = a - (double)d*3600. - (double)min*60.;
d %= 360;
if ((p = strchr(format,'.')) == NULL)
msec=59.;
else if (*(p+2) == 'f' ) {
n = *(p+1) - '0';
msec = 60. - pow(10.,(double)(-n));
} else
msec=60.;
if(sec>msec) sec=msec;
if (strstr(format,"%c"))
snprintf(buf, BUFSZ, newformat, s,d,min,sec);
else
snprintf(buf, BUFSZ, newformat, d,min,sec);
free(newformat);
return buf;
}
#ifndef M_PI
#define M_PI (3.14159265358979323846)
#endif
#define R2D (180./M_PI) // rad. to degr.
#define D2R (M_PI/180.) // degr. to rad.
#define R2S (648000./M_PI) // rad. to sec
#define S2R (M_PI/648000.) // sec. to rad.
#define S360 (1296000.) // sec in 360degr
// By google maps: 43.646683 (43 38 48.0588), 41.440681 (41 26 26.4516)
// (real coordinates should be measured relative to mass center, not geoid)
const double longitude = 149189.175; // SAO longitude 41 26 29.175 (-2:45:45.945)
const double Fi = 157152.7; // SAO latitude 43 39 12.7
const double cos_fi = 0.7235272793; // Cos of SAO latitude
const double sin_fi = 0.6902957888; // Sin --- "" -----
void calc_AZ(double alpha, double delta, double stime, double *az, double *zd){
double sin_t,cos_t, sin_d,cos_d, cos_z;
double t, d, z, a, x, y;
t = (stime - alpha) * 15.;
if (t < 0.)
t += S360; // +360degr
t *= S2R; // -> rad
d = delta * S2R;
sincos(t, &sin_t, &cos_t);
sincos(d, &sin_d, &cos_d);
cos_z = cos_fi * cos_d * cos_t + sin_fi * sin_d;
z = acos(cos_z);
y = cos_d * sin_t;
x = cos_d * sin_fi * cos_t - cos_fi * sin_d;
a = atan2(y, x);
*zd = z * R2S;
*az = a * R2S;
}
double calc_PA(double alpha, double delta, double stime){
double sin_t,cos_t, sin_d,cos_d;
double t, d, p, sp, cp;
t = (stime - alpha) * 15.;
if (t < 0.)
t += S360; // +360degr
t *= S2R; // -> rad
d = delta * S2R;
sin_t = sin(t);
cos_t = cos(t);
sin_d = sin(d);
cos_d = cos(d);
sp = sin_t * cos_fi;
cp = sin_fi * cos_d - sin_d * cos_fi * cos_t;
p = atan2(sp, cp);
if (p < 0.0)
p += 2.0*M_PI;
return(p * R2S);
}
void calc_AD(double az, double zd, double stime, double *alpha, double *delta){
double sin_d, sin_a,cos_a, sin_z,cos_z;
double t, d, z, a, x, y;
a = az * S2R;
z = zd * S2R;
sin_a = sin(a);
cos_a = cos(a);
sin_z = sin(z);
cos_z = cos(z);
y = sin_z * sin_a;
x = cos_a * sin_fi * sin_z + cos_fi * cos_z;
t = atan2(y, x);
if (t < 0.0)
t += 2.0*M_PI;
sin_d = sin_fi * cos_z - cos_fi * cos_a * sin_z;
d = asin(sin_d);
*delta = d * R2S;
*alpha = (stime - t * R2S / 15.);
if (*alpha < 0.0)
*alpha += S360/15.; // +24h
}
void my_sleep(double dt){
int nfd;
struct timeval tv;
tv.tv_sec = (int)dt;
tv.tv_usec = (int)((dt - tv.tv_sec)*1000000.);
slipping:
nfd = select(0, (fd_set *)NULL,(fd_set *)NULL,(fd_set *)NULL, &tv);
if(nfd < 0) {
if(errno == EINTR)
/*On Linux, timeout is modified to reflect the amount of
time not slept; most other implementations DO NOT do this!*/
goto slipping;
fprintf(stderr,"Error in mydelay(){ select() }. %s\n",strerror(errno));
}
}
/**
* print requested information
* @param lvl - requested information level
* @param par_list - list of parameters (any separator) if lvl == REQUESTED_LIST
* @return 0 in case of some error
*/
int bta_print(info_level lvl, char *par_list){
int i, verb = 1, sel = 0;
char *value = NULL;
DBG("lvl: 0x%X, list: %s", lvl, par_list);
if(lvl == NO_INFO && par_list) lvl = REQUESTED_LIST;
else if(lvl == REQUESTED_LIST && !par_list) return 0;
if(lvl == REQUESTED_LIST){
parstr *ptr = (parstr*)parameters_str;
while(ptr->name){
if(strstr(par_list, ptr->name))
parameters_to_show[ptr->pos_idx] = 1;
++ptr;
}
lvl = ALL_INFO;
sel = 1;
}
if(lvl == NO_INFO){ // show all parameters but without values
lvl = ALL_INFO;
verb = 0;
}
#define FMSG(par,hlp, ...) do{if(!sel || parameters_to_show[PAR_ ## par]){printf("\n" #par);if(verb){printf("=\""); \
printf(__VA_ARGS__);printf("\"");}else printf(" (" hlp ")");}}while(0)
#define SMSG(par,hlp, str) do{if(!sel || parameters_to_show[PAR_ ## par]){printf("\n" #par); if(verb)printf("=\"%s\"",str);\
else printf(" (" hlp ")");}}while(0)
/****************************** TIME_INFO *************************************/
if(lvl & TIME_INFO){
SMSG(M_time, "mean solar time", time_asc(M_time + DUT1));
#ifdef EE_time
SMSG(S_time, "mean sidereal time", time_asc(S_time - EE_time));
FMSG(JDate, "julian date", "%.6f", JDate);
#else
SMSG(S_time, "mean sidereal time", time_asc(S_time));
#endif
}
/******************************** ACS_INFO ************************************/
if(lvl & ACS_INFO){
if(verb){
if(Tel_Hardware == Hard_Off) value = "Off";
else if(Tel_Mode != Automatic) value = "Manual";
else{
switch(Sys_Mode){
default:
case SysStop : value = "Stopped"; break;
case SysWait : value = "Waiting"; break;
case SysPointAZ :
case SysPointAD : value = "Pointing"; break;
case SysTrkStop :
case SysTrkStart:
case SysTrkMove :
case SysTrkSeek : value = "Seeking"; break;
case SysTrkOk : value = "Tracking"; break;
case SysTrkCorr : value = "Correction";break;
case SysTest : value = "Testing"; break;
}
}
}
SMSG(Tel_Mode, "telescope mode", value);
if(verb){
switch(Tel_Focus){
default:
case Prime : value = "Prime"; break;
case Nasmyth1 : value = "Nasmyth1"; break;
case Nasmyth2 : value = "Nasmyth2"; break;
}
}
SMSG(Tel_Focus, "focus mode", value);
if(verb){
switch(Sys_Target) {
default:
case TagObject : value = "Object"; break;
case TagPosition : value = "A/Z-Pos."; break;
case TagNest : value = "Nest"; break;
case TagZenith : value = "Zenith"; break;
case TagHorizon : value = "Horizon"; break;
}
}
SMSG(Tel_Taget, "current or last telescope target", value);
if(verb){
if(Tel_Hardware == Hard_On)
switch (P2_State) {
default:
case P2_Off : value = "Stop"; break;
case P2_On : value = "Track"; break;
case P2_Plus : value = "Move+"; break;
case P2_Minus : value = "Move-"; break;
}
else value = "Off";
}
SMSG(P2_Mode, "P2 rotator mode", value);
if(!sel || parameters_to_show[PAR_PCS_Coeffs]){
printf("\nPCS_Coeffs");
if(verb){
printf("=\"");
if(Pos_Corr){
for(i = 0; i < 8; ++i){
printf("%.2f%s", PosCor_Coeff[i], (i == 7) ? "\"" : ",");
}
}else{
printf("Off\"");
}
}else printf(" (Precision Correction System coefficients");
}
if(!sel || parameters_to_show[PAR_code_KOST]){
printf("\ncode_KOST");
if(verb){
printf("=\"0x%04X", code_KOST);
if(code_KOST){
printf(": ");
if(code_KOST & 0x8000) printf("A>0 ");
if(code_KOST & 0x4000) printf("PowerOn ");
if(code_KOST & 0x2000) printf("Guiding ");
if(code_KOST & 0x1000) printf("P2On ");
if(code_KOST & 0x01F0){
printf("CorrSpd=");
if(code_KOST & 0x0010) printf("0.2");
else if(code_KOST & 0x0020) printf("0.4");
else if(code_KOST & 0x0040) printf("1.0");
else if(code_KOST & 0x0080) printf("2.0");
else if(code_KOST & 0x0100) printf("5.0");
printf("''/s ");
}
if(code_KOST & 0x000F){
if(code_KOST & 0x0001) printf("Z+");
else if(code_KOST & 0x0002) printf("Z-");
else if(code_KOST & 0x0004) printf("A+");
else if(code_KOST & 0x0008) printf("A-");
}
}
printf("\"");
}else printf(" (syscodes)");
}
if(verb){
if(Az_Mode) value = "On";
else value = "Off";
}
SMSG(Az_Reverce, "reverce of azimuth direction", value);
if(!sel || parameters_to_show[PAR_Az_EndSw]){
printf("\nAz_EndSw");
if(verb){
printf("=\"");
if(switch_A){
if(switch_A & Sw_minus_A) printf("A<0 ");
if(switch_A & Sw_plus240_A) printf("A=+240 ");
if(switch_A & Sw_minus240_A)printf("A=-240 ");
if(switch_A & Sw_minus45_A) printf("horizon");
}else printf("Off");
printf("\"");
}else printf(" (Azimuth end-switches)");
}
if(!sel || parameters_to_show[PAR_Zen_EndSw]){
printf("\nZen_EndSw");
if(verb){
printf("=\"");
if(switch_Z){
if(switch_Z & Sw_0_Z) printf("Zenith ");
if(switch_Z & Sw_5_Z) printf("Z<=5 ");
if(switch_Z & Sw_20_Z) printf("Z<=20 ");
if(switch_Z & Sw_60_Z) printf("Z>=60 ");
if(switch_Z & Sw_80_Z) printf("Z>=80 ");
if(switch_Z & Sw_90_Z) printf("Z=90 ");
}else printf("Off");
printf("\"");
}else printf(" (Zenith end-switches)");
}
if(!sel || parameters_to_show[PAR_P2_EndSw]){
printf("\nP2_EndSw");
if(verb){
printf("=\"");
if(switch_P){
if(switch_P & Sw_22_P) printf("22degr ");
if(switch_P & Sw_89_P) printf("89degr ");
if(switch_P & Sw_Sm_P) printf("SMOKE");
}else printf("Off");
printf("\"");
}else printf(" (P2 end-switches)");
}
FMSG(Worm_A, "worm A position", "%gmkm", worm_A);
FMSG(Worm_Z, "worm Z position", "%gmkm", worm_Z);
if(verb && !sel){
for(i = 0; i < MesgNum; ++i){
switch (Sys_Mesg(i).type){
case MesgInfor : value = "information"; break;
case MesgWarn : value = "warning"; break;
case MesgFault : value = "FAULT"; break;
case MesgLog : value = "log"; break;
default : value = NULL;
}
if(!value) continue;
printf("\nMessage[%d](num=%d, status=\"%s\")=\"%s\"", i,
Sys_Mesg(i).seq_num, value, Sys_Mesg(i).text);
}
}
if(!sel || parameters_to_show[PAR_Lock_Flags]){
printf("\nLock_Flags");
if(verb){
printf("=\"");
if(LockFlags){
if(A_Locked) printf("A ");
if(Z_Locked) printf("Z ");
if(P_Locked) printf("P2 ");
if(F_Locked) printf("F ");
if(D_Locked) printf("D ");
}else printf("Off");
printf("\"");
}else printf(" (locked motors)");
}
FMSG(Oil_Pres, "oil pressure in A,Z & tank (Pa)", "p(A)=%.1f, p(Z)=%.1f, p(tank)=%.1f", PressOilA, PressOilZ, PressOilTank);
FMSG(Oil_Temp, "oil temperature (degrC)", "%.1f", OilTemper1);
FMSG(Oil_Cool_Temp, "oil coolant themperature (degrC)", "%.1f", OilTemper2);
}
/************************* BASIC_COORDS ***************************************/
if(lvl & BASIC_COORDS){ // basic coordinates: cur, src, inp, tel
SMSG(CurAlpha, "current", time_asc(CurAlpha));
SMSG(CurDelta, "current", angle_asc(CurDelta));
SMSG(SrcAlpha, "source", time_asc(SrcAlpha));
SMSG(SrcDelta, "source", angle_asc(SrcDelta));
SMSG(InpAlpha, "input", time_asc(InpAlpha));
SMSG(InpDelta, "input", angle_asc(InpDelta));
SMSG(CurAzim, "current", angle_fmt(tag_A,"%c%03d:%02d:%04.1f"));
SMSG(CurZenD, "current", angle_fmt(tag_Z,"%02d:%02d:%04.1f"));
SMSG(InpAzim, "input", angle_fmt(InpAzim,"%c%03d:%02d:%04.1f"));
SMSG(InpZenD, "input", angle_fmt(InpZdist,"%02d:%02d:%04.1f"));
SMSG(CurPA, "current", angle_fmt(tag_P,"%03d:%02d:%04.1f"));
SMSG(SrcPA, "source", angle_fmt(calc_PA(SrcAlpha,SrcDelta,S_time),"%03d:%02d:%04.1f"));
SMSG(InpPA, "input", angle_fmt(calc_PA(InpAlpha,InpDelta,S_time),"%03d:%02d:%04.1f"));
SMSG(TelPA, "telescope", angle_fmt(calc_PA(val_Alp, val_Del, S_time),"%03d:%02d:%04.1f"));
FMSG(ValFoc, "focus value", "%0.2f", val_F);
}
if(lvl & EXTENDED_COORDS){
SMSG(ValAzim, "from encoder", angle_fmt(val_A,"%c%03d:%02d:%04.1f"));
SMSG(ValZenD, "from encoder", angle_fmt(val_Z,"%02d:%02d:%04.1f"));
SMSG(ValP2, "from encoder", angle_fmt(val_P,"%03d:%02d:%04.1f"));
SMSG(ValDome, "from encoder", angle_fmt(val_D,"%c%03d:%02d:%04.1f"));
SMSG(DiffAzim, "A difference", angle_fmt(Diff_A,"%c%03d:%02d:%04.1f"));
SMSG(DiffZenD, "Z difference", angle_fmt(Diff_Z,"%c%02d:%02d:%04.1f"));
SMSG(DiffP2, "P2 difference", angle_fmt(Diff_P,"%c%03d:%02d:%04.1f"));
SMSG(DiffDome, "DomeAz difference", angle_fmt(val_A-val_D,"%c%03d:%02d:%04.1f"));
SMSG(VelAzim, "A velocity", angle_fmt(vel_A,"%c%02d:%02d:%04.1f"));
SMSG(VelZenD, "Z velocity", angle_fmt(vel_Z,"%c%02d:%02d:%04.1f"));
SMSG(VelP2, "P2 velocity", angle_fmt(vel_P,"%c%02d:%02d:%04.1f"));
SMSG(VelPA, "object PA velocity", angle_fmt(vel_objP,"%c%02d:%02d:%04.1f"));
SMSG(VelDome, "DomeAz velocity", angle_fmt(vel_D,"%c%02d:%02d:%04.1f"));
double corAlp = 0.,corDel = 0.,corA = 0.,corZ = 0.;
double PCSA = 0., PCSZ = 0., refr = 0.;
if(verb){
if(Sys_Mode == SysTrkSeek || Sys_Mode == SysTrkOk || Sys_Mode == SysTrkCorr){
double curA,curZ,srcA,srcZ;
corAlp = CurAlpha-SrcAlpha;
corDel = CurDelta-SrcDelta;
if(corAlp > 23*3600.) corAlp -= 24*3600.;
if(corAlp < -23*3600.) corAlp += 24*3600.;
calc_AZ(SrcAlpha, SrcDelta, S_time, &srcA, &srcZ);
calc_AZ(CurAlpha, CurDelta, S_time, &curA, &curZ);
corA = curA - srcA;
corZ = curZ - srcZ;
PCSA = tel_cor_A; PCSZ = tel_cor_Z; refr = tel_ref_Z;
}
}
FMSG(CorrPCS, "Point Correction System value",
"A=%s, Z=%s", angle_fmt(PCSA, "%c%01d:%02d:%04.1f"),
angle_fmt(PCSZ, "%c%01d:%02d:%04.1f"));
SMSG(Refraction, "calculated refraction value", angle_fmt(refr, "%c%01d:%02d:%04.1f"));
SMSG(CorrAlpha, "correction by RA", angle_fmt(corAlp,"%c%01d:%02d:%05.2f"));
SMSG(CorrDelta, "correction by Decl", angle_fmt(corDel,"%c%01d:%02d:%04.1f"));
SMSG(CorrAzim, "correction by A", angle_fmt(corA,"%c%01d:%02d:%04.1f"));
SMSG(CorrZenD, "correction by Z", angle_fmt(corZ,"%c%01d:%02d:%04.1f"));
if(verb){
switch(Foc_State){
case Foc_Hminus :
case Foc_Hplus : value = "fast move"; break;
case Foc_Lminus :
case Foc_Lplus : value = "slow move"; break;
default : value = "stopped";
}
}
SMSG(Foc_State, "focus motor state", value);
}
/************************** METEO_INFO ****************************************/
if(lvl & METEO_INFO){
FMSG(ValTout, "outern temperature (DegrC)", "%+05.1f", val_T1);
FMSG(ValTind, "indome temperature (DegrC)", "%+05.1f", val_T2);
FMSG(ValTmir, "mirror temperature (DegrC)", "%+05.1f", val_T3);
FMSG(ValPres, "atm. pressure (mmHg)", "%+05.1f", val_B);
FMSG(ValWind, "wind speed (m/s)", "%04.1f", val_Wnd);
double w10 = -1., w15 = -1., pre = -1.;
if(verb){
if(Wnd10_time > 0.1 && Wnd10_time <= M_time){
w10 = (M_time-Wnd10_time)/60.;
w15 = (M_time-Wnd15_time)/60.;
}
if(Precip_time > 0.1 && Precip_time <= M_time)
pre = (M_time-Precip_time)/60.;
}
FMSG(Blast10, "wind blast >=10m/s (minutes ago)", "%.1f", w10);
FMSG(Blast15, "wind blast >=15m/s (minutes ago)", "%.1f", w15);
FMSG(Precipitation, "last precipitation (minutes ago)", "%.1f", pre);
FMSG(ValHumd, "Humidity, %%", "%04.1f", val_Hmd);
}
// FMSG("", "", "", ));
/******************************************************************************/
printf("\n");
#undef SMSG
#undef FMSG
return 1;
}
void show_infolevels(){
printf("\n\t\tList of information levels: \n\tall");
levelstr *sptr = (levelstr *)infolevels_str;
info_level lastlvl = NO_INFO;
int start = 1; // 1 - first message, 0 - first message in line, 2 - next message in line
for(; ; ++sptr){
info_level l = sptr->lvl;
if(lastlvl == l){ // more variants
if(start != 2){
printf(" (");
start = 2;
}else
printf(" ,");
}else{
if(start == 2) printf(")");
printf("\n");
start = 0;
lastlvl = l;
}
if(!sptr->name) break;
if(start != 2) printf("\t");
printf(sptr->name);
}
}
info_level get_infolevel(char* infostr){
FNAME();
info_level ret = NO_INFO;
if(strcasestr(infostr, "all")) return ALL_INFO;
levelstr *sptr = (levelstr *)infolevels_str;
for(; sptr->name; ++sptr){
if(strcasestr(infostr, sptr->name))
ret |= sptr->lvl;
}
return ret;
}

41
bta_print.h Normal file
View File

@ -0,0 +1,41 @@
/*
* bta_print.h
*
* Copyright 2015 Edward V. Emelianov <eddy@sao.ru, edward.emelianoff@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#pragma once
#ifndef __BTA_PRINT_H__
#define __BTA_PRINT_H__
typedef enum{
NO_INFO = 0 // don't show anything
,BASIC_COORDS = 1 // show basic coordinates
,METEO_INFO = 2 // meteo info
,TIME_INFO = 4 // all info about time
,ACS_INFO = 8 // extended ACS information
,EXTENDED_COORDS = 0x11 // extended coords (val, spd, corr) + basic
,ALL_INFO = 0xff // all information available
,REQUESTED_LIST = 0x8000 // show only parameters given in list
} info_level;
int bta_print (info_level lvl, char *par_list);
void show_infolevels();
info_level get_infolevel(char* infostr);
#endif // __BTA_PRINT_H__

344
bta_shdata.c Normal file
View File

@ -0,0 +1,344 @@
#include "bta_shdata.h"
#include "usefull_macros.h"
#pragma pack(push, 4)
// Main command channel (level 5)
struct CMD_Queue mcmd = {{"Mcmd"}, 0200,0,-1,0};
// Operator command channel (level 4)
struct CMD_Queue ocmd = {{"Ocmd"}, 0200,0,-1,0};
// User command channel (level 2/3)
struct CMD_Queue ucmd = {{"Ucmd"}, 0200,0,-1,0};
static char msg[80];
#define PERR(...) do{sprintf(msg, __VA_ARGS__); perror(msg);} while(0)
#ifndef BTA_MODULE
struct BTA_Data *sdt;
struct BTA_Local *sdtl;
struct SHM_Block sdat = {
{"Sdat"},
sizeof(struct BTA_Data),
2048,0444,
SHM_RDONLY,
bta_data_init,
bta_data_check,
bta_data_close,
ClientSide,-1,NULL
};
int snd_id = -1; // client sender ID
int cmd_src_pid = 0; // next command source PID
uint32_t cmd_src_ip = 0;// next command source IP
/**
* Init data
*/
void bta_data_init() {
sdt = (struct BTA_Data *)sdat.addr;
sdtl = (struct BTA_Local *)(sdat.addr+sizeof(struct BTA_Data));
if(sdat.side == ClientSide) {
if(sdt->magic != sdat.key.code) {
WARN("Wrong shared data (maybe server turned off)");
}
if(sdt->version == 0) {
WARN("Null shared data version (maybe server turned off)");
}
else if(sdt->version != BTA_Data_Ver) {
WARN("Wrong shared data version: I'am - %d, but server - %d ...",
BTA_Data_Ver, sdt->version );
}
if(sdt->size != sdat.size) {
if(sdt->size > sdat.size) {
WARN("Wrong shared area size: I needs - %d, but server - %d ...",
sdat.size, sdt->size );
} else {
WARN("Attention! Too little shared data structure!");
WARN("I needs - %d, but server gives only %d ...",
sdat.size, sdt->size );
WARN("May be server's version too old!?");
}
}
return;
}
/* ServerSide */
if(sdt->magic == sdat.key.code &&
sdt->version == BTA_Data_Ver &&
sdt->size == sdat.size)
return;
memset(sdat.addr, 0, sdat.maxsize);
sdt->magic = sdat.key.code;
sdt->version = BTA_Data_Ver;
sdt->size = sdat.size;
Tel_Hardware = Hard_On;
Pos_Corr = PC_On;
TrkOk_Mode = UseDiffVel | UseDiffAZ ;
inp_B = 591.;
Pressure = 595.;
PEP_code_A = 0x002aaa;
PEP_code_Z = 0x002aaa;
PEP_code_P = 0x002aaa;
PEP_code_F = 0x002aaa;
PEP_code_D = 0x002aaa;
DomeSEW_N = 1;
}
int bta_data_check() {
return( (sdt->magic == sdat.key.code) && (sdt->version == BTA_Data_Ver) );
}
void bta_data_close() {
if(sdat.side == ServerSide) {
sdt->magic = 0;
sdt->version = 0;
}
}
/**
* Allocate shared memory segment
*/
int get_shm_block( struct SHM_Block *sb, int server) {
int getsize = (server)? sb->maxsize : sb->size;
// first try to find existing one
sb->id = shmget(sb->key.code, getsize, sb->mode);
if(sb->id < 0 && errno == ENOENT && server){
// if no - try to create a new one
int cresize = sb->maxsize;
if(sb->size > cresize){
WARN("Wrong shm maxsize(%d) < realsize(%d)",sb->maxsize,sb->size);
cresize = sb->size;
}
sb->id = shmget(sb->key.code, cresize, IPC_CREAT|IPC_EXCL|sb->mode);
}
if(sb->id < 0){
if(server)
PERR("Can't create shared memory segment '%s'",sb->key.name);
else
PERR("Can't find shared segment '%s' (maybe no server process) ",sb->key.name);
return 0;
}
// attach it to our memory space
sb->addr = (unsigned char *) shmat(sb->id, NULL, sb->atflag);
if((long)sb->addr == -1){
PERR("Can't attach shared memory segment '%s'",sb->key.name);
return 0;
}
if(server && (shmctl(sb->id, SHM_LOCK, NULL) < 0)){
PERR("Can't prevents swapping of shared memory segment '%s'",sb->key.name);
return 0;
}
DBG("Create & attach shared memory segment '%s' %dbytes at %lx",
sb->key.name, sb->size, (uint64_t)sb->addr);
sb->side = server;
if(sb->init != NULL)
sb->init();
return 1;
}
int close_shm_block(struct SHM_Block *sb){
int ret;
if(sb->close != NULL)
sb->close();
if(sb->side == ServerSide) {
// ret = shmctl(sb->id, SHM_UNLOCK, NULL);
ret = shmctl(sb->id, IPC_RMID, NULL);
}
ret = shmdt (sb->addr);
return(ret);
}
/**
* Create|Find command queue
*/
void get_cmd_queue(struct CMD_Queue *cq, int server){
if (!server && cq->id >= 0) { //if already in use set current
snd_id = cq->id;
return;
}
// first try to find existing one
cq->id = msgget(cq->key.code, cq->mode);
// if no - try to create a new one
if(cq->id<0 && errno == ENOENT && server)
cq->id = msgget(cq->key.code, IPC_CREAT|IPC_EXCL|cq->mode);
if(cq->id<0){
if(server)
PERR("Can't create comand queue '%s'",cq->key.name);
else
PERR("Can't find comand queue '%s' (maybe no server process) ",cq->key.name);
return;
}
cq->side = server;
if(server){
char buf[120]; /* выбросить все команды из очереди */
while(msgrcv(cq->id, (struct msgbuf *)buf, 112, 0, IPC_NOWAIT) > 0);
}else
snd_id = cq->id;
cq->acckey = 0;
}
#endif // BTA_MODULE
int check_shm_block( struct SHM_Block *sb) {
if(sb->check)
return(sb->check());
else return(0);
}
/**
* Set access key in current channel
*/
void set_acckey(uint32_t newkey){
if(snd_id < 0) return;
if(ucmd.id == snd_id) ucmd.acckey = newkey;
else if(ocmd.id == snd_id) ocmd.acckey = newkey;
else if(mcmd.id == snd_id) mcmd.acckey = newkey;
}
/**
* Setup source data for one following command if default values
* (IP == 0 - local, PID = current) not suits
*/
void set_cmd_src(uint32_t ip, int pid) {
cmd_src_pid = pid;
cmd_src_ip = ip;
}
#pragma pack(push, 4)
/**
* Send client commands to server
*/
void send_cmd(int cmd_code, char *buf, int size) {
struct my_msgbuf mbuf;
if(snd_id < 0) return;
if(size > 100) size = 100;
if(cmd_code > 0)
mbuf.mtype = cmd_code;
else
return;
if(ucmd.id == snd_id) mbuf.acckey = ucmd.acckey;
else if(ocmd.id == snd_id) mbuf.acckey = ocmd.acckey;
else if(mcmd.id == snd_id) mbuf.acckey = mcmd.acckey;
mbuf.src_pid = cmd_src_pid ? cmd_src_pid : getpid();
mbuf.src_ip = cmd_src_ip;
cmd_src_pid = cmd_src_ip = 0;
if(size > 0)
memcpy(mbuf.mtext, buf, size);
else {
mbuf.mtext[0] = 0;
size = 1;
}
msgsnd(snd_id, (struct msgbuf *)&mbuf, size+12, IPC_NOWAIT);
}
void send_cmd_noarg(int cmd_code) {
send_cmd(cmd_code, NULL, 0);
}
void send_cmd_str(int cmd_code, char *arg) {
send_cmd(cmd_code, arg, strlen(arg)+1);
}
void send_cmd_i1(int cmd_code, int32_t arg1) {
send_cmd(cmd_code, (char *)&arg1, sizeof(int32_t));
}
void send_cmd_i2(int cmd_code, int32_t arg1, int32_t arg2) {
int32_t ibuf[2];
ibuf[0] = arg1;
ibuf[1] = arg2;
send_cmd(cmd_code, (char *)ibuf, 2*sizeof(int32_t));
}
void send_cmd_i3(int cmd_code, int32_t arg1, int32_t arg2, int32_t arg3) {
int32_t ibuf[3];
ibuf[0] = arg1;
ibuf[1] = arg2;
ibuf[2] = arg3;
send_cmd(cmd_code, (char *)ibuf, 3*sizeof(int32_t));
}
void send_cmd_i4(int cmd_code, int32_t arg1, int32_t arg2, int32_t arg3, int32_t arg4) {
int32_t ibuf[4];
ibuf[0] = arg1;
ibuf[1] = arg2;
ibuf[2] = arg3;
ibuf[3] = arg4;
send_cmd(cmd_code, (char *)ibuf, 4*sizeof(int32_t));
}
void send_cmd_d1(int32_t cmd_code, double arg1) {
send_cmd(cmd_code, (char *)&arg1, sizeof(double));
}
void send_cmd_d2(int cmd_code, double arg1, double arg2) {
double dbuf[2];
dbuf[0] = arg1;
dbuf[1] = arg2;
send_cmd(cmd_code, (char *)dbuf, 2*sizeof(double));
}
void send_cmd_i1d1(int cmd_code, int32_t arg1, double arg2) {
struct {
int32_t ival;
double dval;
} buf;
buf.ival = arg1;
buf.dval = arg2;
send_cmd(cmd_code, (char *)&buf, sizeof(buf));
}
void send_cmd_i2d1(int cmd_code, int32_t arg1, int32_t arg2, double arg3) {
struct {
int32_t ival[2];
double dval;
} buf;
buf.ival[0] = arg1;
buf.ival[1] = arg2;
buf.dval = arg3;
send_cmd(cmd_code, (char *)&buf, sizeof(buf));
}
void send_cmd_i3d1(int cmd_code, int32_t arg1, int32_t arg2, int32_t arg3, double arg4) {
struct {
int32_t ival[3];
double dval;
} buf;
buf.ival[0] = arg1;
buf.ival[1] = arg2;
buf.ival[2] = arg3;
buf.dval = arg4;
send_cmd(cmd_code, (char *)&buf, sizeof(buf));
}
void encode_lev_passwd(char *passwd, int nlev, uint32_t *keylev, uint32_t *codlev){
char salt[4];
char *encr;
union {
uint32_t ui;
char c[4];
} key, cod;
sprintf(salt,"L%1d",nlev);
encr = (char *)crypt(passwd, salt);
cod.c[0] = encr[2];
key.c[0] = encr[3];
cod.c[1] = encr[4];
key.c[1] = encr[5];
cod.c[2] = encr[6];
key.c[2] = encr[7];
cod.c[3] = encr[8];
key.c[3] = encr[9];
*keylev = key.ui;
*codlev = cod.ui;
}
int find_lev_passwd(char *passwd, uint32_t *keylev, uint32_t *codlev){
int nlev;
for(nlev = 5; nlev > 0; --nlev){
encode_lev_passwd(passwd, nlev, keylev, codlev);
if(*codlev == code_Lev(nlev)) break;
}
return(nlev);
}
int check_lev_passwd(char *passwd){
uint32_t keylev,codlev;
int nlev;
nlev = find_lev_passwd(passwd, &keylev, &codlev);
if(nlev > 0) set_acckey(keylev);
return(nlev);
}
#pragma pack(pop)

850
bta_shdata.h Normal file
View File

@ -0,0 +1,850 @@
#pragma once
#ifndef __BTA_SHDATA_H__
#define __BTA_SHDATA_H__
#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <stdint.h>
#include <string.h>
#include <sys/ipc.h>
#include <sys/shm.h>
#include <sys/msg.h>
#include <errno.h>
#pragma pack(push, 4)
/*
* Shared memory block
*/
struct SHM_Block {
union {
char name[5]; // memory segment identificator
key_t code;
} key;
int32_t size; // size of memory used
int32_t maxsize; // size when created
int32_t mode; // access mode (rwxrwxrwx)
int32_t atflag; // connection mode (SHM_RDONLY or 0)
void (*init)(); // init function
int32_t (*check)(); // test function
void (*close)(); // deinit function
int32_t side; // connection type: client/server
int32_t id; // connection identificator
uint8_t *addr; // connection address
};
extern struct SHM_Block sdat;
/*
* Command queue descriptor
*/
struct CMD_Queue {
union {
char name[5]; // queue key
key_t code;
} key;
int32_t mode; // access mode (rwxrwxrwx)
int32_t side; // connection type (Sender/Receiver - server/client)
int32_t id; // connection identificator
uint32_t acckey; // access key (for transmission from client to server)
};
extern struct CMD_Queue mcmd;
extern struct CMD_Queue ocmd;
extern struct CMD_Queue ucmd;
void send_cmd_noarg(int);
void send_cmd_str(int, char *);
void send_cmd_i1(int, int32_t);
void send_cmd_i2(int, int32_t, int32_t);
void send_cmd_i3(int, int32_t, int32_t, int32_t);
void send_cmd_i4(int, int32_t, int32_t, int32_t, int32_t);
void send_cmd_d1(int, double);
void send_cmd_d2(int, double, double);
void send_cmd_i1d1(int, int32_t, double);
void send_cmd_i2d1(int, int32_t, int32_t, double);
void send_cmd_i3d1(int, int32_t, int32_t, int32_t, double);
/*******************************************************************************
* Command list *
*******************************************************************************/
/* name code args type */
// Stop telescope
#define StopTel 1
#define StopTeleskope() send_cmd_noarg( 1 )
// High/low speed
#define StartHS 2
#define StartHighSpeed() send_cmd_noarg( 2 )
#define StartLS 3
#define StartLowSpeed() send_cmd_noarg( 3 )
// Timer setup (Ch7_15 or SysTimer)
#define SetTmr 4
#define SetTimerMode(T) send_cmd_i1 ( 4, (int)(T))
// Simulation (modeling) mode
#define SetModMod 5
#define SetModelMode(M) send_cmd_i1 ( 5, (int)(M))
// Azimuth speed code
#define SetCodA 6
#define SetPKN_A(iA,sA) send_cmd_i2 ( 6, (int)(iA),(int)(sA))
// Zenith speed code
#define SetCodZ 7
#define SetPKN_Z(iZ) send_cmd_i1 ( 7, (int)(iZ))
// Parangle speed code
#define SetCodP 8
#define SetPKN_P(iP) send_cmd_i1 ( 8, (int)(iP))
// Set Az velocity
#define SetVA 9
#define SetSpeedA(vA) send_cmd_d1 ( 9, (double)(vA))
// Set Z velocity
#define SetVZ 10
#define SetSpeedZ(vZ) send_cmd_d1 (10, (double)(vZ))
// Set P velocity
#define SetVP 11
#define SetSpeedP(vP) send_cmd_d1 (11, (double)(vP))
// Set new polar coordinates
#define SetAD 12
#define SetRADec(Alp,Del) send_cmd_d2 (12, (double)(Alp),(double)(Del))
// Set new azimutal coordinates
#define SetAZ 13
#define SetAzimZ(A,Z) send_cmd_d2 (13, (double)(A),(double)(Z))
// Goto new object by polar coords
#define GoToAD 14
#define GoToObject() send_cmd_noarg(14 )
// Start steering to object by polar coords
#define MoveToAD 15
#define MoveToObject() send_cmd_noarg(15 )
// Go to object by azimutal coords
#define GoToAZ 16
#define GoToAzimZ() send_cmd_noarg(16 )
// Set A&Z for simulation
#define WriteAZ 17
#define WriteModelAZ() send_cmd_noarg(17 )
// Set P2 mode
#define SetModP 18
#define SetPMode(pmod) send_cmd_i1 (18, (int)(pmod))
// Move(+-1)/Stop(0) P2
#define P2Move 19
#define MoveP2(dir) send_cmd_i1 (19, (int)(dir))
// Move(+-2,+-1)/Stop(0) focus
#define FocMove 20
#define MoveFocus(speed,time) send_cmd_i1d1(20,(int)(speed),(double)(time))
// Use/don't use pointing correction system
#define UsePCorr 21
#define SwitchPosCorr(pc_flag) send_cmd_i1 (21, (int)(pc_flag))
// Tracking flags
#define SetTrkFlags 22
#define SetTrkOkMode(trk_flags) send_cmd_i1 (22, (int)(trk_flags))
// Set focus (0 - primary, 1 - N1, 2 - N2)
#define SetTFoc 23
#define SetTelFocus(N) send_cmd_i1 ( 23, (int)(N))
// Set intrinsic move parameters by RA/Decl
#define SetVAD 24
#define SetVelAD(VAlp,VDel) send_cmd_d2 (24, (double)(VAlp),(double)(VDel))
// Reverse Azimuth direction when pointing
#define SetRevA 25
#define SetAzRevers(amod) send_cmd_i1 (25, (int)(amod))
// Set P2 velocity
#define SetVP2 26
#define SetVelP2(vP2) send_cmd_d1 (26, (double)(vP2))
// Set pointing target
#define SetTarg 27
#define SetSysTarg(Targ) send_cmd_i1 (27, (int)(Targ))
// Send message to all clients (+write into protocol)
#define SendMsg 28
#define SendMessage(Mesg) send_cmd_str (28, (char *)(Mesg))
// RA/Decl user correction
#define CorrAD 29
#define DoADcorr(dAlp,dDel) send_cmd_d2 (29, (double)(dAlp),(double)(dDel))
// A/Z user correction
#define CorrAZ 30
#define DoAZcorr(dA,dZ) send_cmd_d2 (30, (double)(dA),(double)(dZ))
// sec A/Z user correction speed
#define SetVCAZ 31
#define SetVCorr(vA,vZ) send_cmd_d2 (31, (double)(vA),(double)(vZ))
// move P2 with given velocity for a given time
#define P2MoveTo 32
#define MoveP2To(vP2,time) send_cmd_d2 (32, (double)(vP2),(double)(time))
// Go to t/Decl position
#define GoToTD 33
#define GoToSat() send_cmd_noarg (33 )
// Move to t/Decl
#define MoveToTD 34
#define MoveToSat() send_cmd_noarg (34 )
// Empty command for synchronisation
#define NullCom 35
#define SyncCom() send_cmd_noarg (35 )
// Button "Start"
#define StartTel 36
#define StartTeleskope() send_cmd_noarg(36 )
// Set telescope mode
#define SetTMod 37
#define SetTelMode(M) send_cmd_i1 ( 37, (int)(M))
// Turn telescope on (oil etc)
#define TelOn 38
#define TeleskopeOn() send_cmd_noarg(38 )
// Dome mode
#define SetModD 39
#define SetDomeMode(dmod) send_cmd_i1 (39, (int)(dmod))
// Move(+-3,+-2,+-1)/Stop(0) dome
#define DomeMove 40
#define MoveDome(speed,time) send_cmd_i1d1(40,(int)(speed),(double)(time))
// Set account password
#define SetPass 41
#define SetPasswd(LPass) send_cmd_str (41, (char *)(LPass))
// Set code of access level
#define SetLevC 42
#define SetLevCode(Nlev,Cod) send_cmd_i2(42, (int)(Nlev),(int)(Cod))
// Set key for access level
#define SetLevK 43
#define SetLevKey(Nlev,Key) send_cmd_i2(43, (int)(Nlev),(int)(Key))
// Setup network
#define SetNet 44
#define SetNetAcc(Mask,Addr) send_cmd_i2(44, (int)(Mask),(int)(Addr))
// Input meteo data
#define SetMet 45
#define SetMeteo(m_id,m_val) send_cmd_i1d1(45,(int)(m_id),(double)(m_val))
// Cancel meteo data
#define TurnMetOff 46
#define TurnMeteoOff(m_id) send_cmd_i1 (46, (int)(m_id))
// Set time correction (IERS DUT1=UT1-UTC)
#define SetDUT1 47
#define SetDtime(dT) send_cmd_d1 (47, (double)(dT))
// Set polar motion (IERS polar motion)
#define SetPM 48
#define SetPolMot(Xp,Yp) send_cmd_d2 (48, (double)(Xp),(double)(Yp))
// Get SEW parameter
#define GetSEW 49
#define GetSEWparam(Ndrv,Indx,Cnt) send_cmd_i3(49,(int)(Ndrv),(int)(Indx),(int)(Cnt))
// Set SEW parameter
#define PutSEW 50
#define PutSEWparam(Ndrv,Indx,Key,Val) send_cmd_i4(50,(int)(Ndrv),(int)(Indx),(int)(Key),(int)(Val))
// Set lock flags
#define SetLocks 51
#define SetLockFlags(f) send_cmd_i1 (SetLocks, (int)(f))
// Clear lock flags
#define ClearLocks 52
#define ClearLockFlags(f) send_cmd_i1 (ClearLocks, (int)(f))
// Set PEP-RK bits
#define SetRKbits 53
#define AddRKbits(f) send_cmd_i1 (SetRKbits, (int)(f))
// Clear PEP-RK bits
#define ClrRKbits 54
#define ClearRKbits(f) send_cmd_i1 (ClrRKbits, (int)(f))
// Set SEW dome motor number (for indication)
#define SetSEWnd 55
#define SetDomeDrive(ND) send_cmd_i1 (SetSEWnd, (int)(ND))
// Turn SEW controllers of dome on/off
#define SEWsDome 56
#define DomeSEW(OnOff) send_cmd_i1 (SEWsDome, (int)(OnOff))
/*******************************************************************************
* BTA data structure definitions *
*******************************************************************************/
#define ServPID (sdt->pid) // PID of main program
// model
#define UseModel (sdt->model) // model variants
enum{
NoModel = 0 // OFF
,CheckModel // control motors by model
,DriveModel // "blind" management without real sensors
,FullModel // full model without telescope
};
// timer
#define ClockType (sdt->timer) // which timer to use
enum{
Ch7_15 = 0 // Inner timer with synchronisation by CH7_15
,SysTimer // System timer (synchronisation unknown)
,ExtSynchro // External synchronisation (bta_time or xntpd)
};
// system
#define Sys_Mode (sdt->system) // main system mode
enum{
SysStop = 0 // Stop
,SysWait // Wait for start (pointing)
,SysPointAZ // Pointing by A/Z
,SysPointAD // Pointing by RA/Decl
,SysTrkStop // Tracking stop
,SysTrkStart // Start tracking (acceleration to nominal velocity)
,SysTrkMove // Tracking move to object
,SysTrkSeek // Tracking in seeking mode
,SysTrkOk // Tracking OK
,SysTrkCorr // Correction of tracking position
,SysTest // Test
};
// sys_target
#define Sys_Target (sdt->sys_target) // system pointing target
enum{
TagPosition = 0 // point by A/Z
,TagObject // point by RA/Decl
,TagNest // point to "nest"
,TagZenith // point to zenith
,TagHorizon // point to horizon
,TagStatObj // point to statinary object (t/Decl)
};
// tel_focus
#define Tel_Focus (sdt->tel_focus) // telescope focus type
enum{
Prime = 0
,Nasmyth1
,Nasmyth2
};
// PCS
#define PosCor_Coeff (sdt->pc_coeff) // pointing correction system coefficients
// tel_state
#define Tel_State (sdt->tel_state) // telescope state
#define Req_State (sdt->req_state) // required state
enum{
Stopping = 0
,Pointing
,Tracking
};
// tel_hard_state
#define Tel_Hardware (sdt->tel_hard_state) // Power state
enum{
Hard_Off = 0
,Hard_On
};
// tel_mode
#define Tel_Mode (sdt->tel_mode) // telescope mode
enum{
Automatic = 0 // Automatic (normal) mode
,Manual = 1 // manual mode
,ZenHor = 2 // work when Z<5 || Z>80
,A_Move = 4 // hand move by A
,Z_Move = 8 // hand move by Z
,Balance =0x10// balancing
};
// az_mode
#define Az_Mode (sdt->az_mode) // azimuth reverce
enum{
Rev_Off = 0 // move by nearest way
,Rev_On // move by longest way
};
// p2_state
#define P2_State (sdt->p2_state) // P2 motor state
#define P2_Mode (sdt->p2_req_mode)
enum{
P2_Off = 0 // Stop
,P2_On // Guiding
,P2_Plus // Move to +
,P2_Minus = -2 // Move to -
};
// focus_state
#define Foc_State (sdt->focus_state) // focus motor state
enum{
Foc_Hminus = -2// fast "-" move
,Foc_Lminus // slow "-" move
,Foc_Off // Off
,Foc_Lplus // slow "+" move
,Foc_Hplus // fast "+" move
};
// dome_state
#define Dome_State (sdt->dome_state) // dome motors state
enum{
D_Hminus = -3 // speeds: low, medium, high
,D_Mminus
,D_Lminus
,D_Off // off
,D_Lplus
,D_Mplus
,D_Hplus
,D_On = 7 // auto
};
// pcor_mode
#define Pos_Corr (sdt->pcor_mode) // pointing correction mode
enum{
PC_Off = 0
,PC_On
};
// trkok_mode
#define TrkOk_Mode (sdt->trkok_mode) // tracking mode
enum{
UseDiffVel = 1 // Isodrome (correction by real motors speed)
,UseDiffAZ = 2 // Tracking by coordinate difference
,UseDFlt = 4 // Turn on digital filter
};
// input RA/Decl values
#define InpAlpha (sdt->i_alpha)
#define InpDelta (sdt->i_delta)
// current source RA/Decl values
#define SrcAlpha (sdt->s_alpha)
#define SrcDelta (sdt->s_delta)
// intrinsic object velocity
#define VelAlpha (sdt->v_alpha)
#define VelDelta (sdt->v_delta)
// input A/Z values
#define InpAzim (sdt->i_azim)
#define InpZdist (sdt->i_zdist)
// calculated values
#define CurAlpha (sdt->c_alpha)
#define CurDelta (sdt->c_delta)
// current values (from sensors)
#define tag_A (sdt->tag_a)
#define tag_Z (sdt->tag_z)
#define tag_P (sdt->tag_p)
// calculated corrections
#define pos_cor_A (sdt->pcor_a)
#define pos_cor_Z (sdt->pcor_z)
#define refract_Z (sdt->refr_z)
// reverse calculation corr.
#define tel_cor_A (sdt->tcor_a)
#define tel_cor_Z (sdt->tcor_z)
#define tel_ref_Z (sdt->tref_z)
// coords difference
#define Diff_A (sdt->diff_a)
#define Diff_Z (sdt->diff_z)
#define Diff_P (sdt->diff_p)
// base object velocity
#define vel_objA (sdt->vbasea)
#define vel_objZ (sdt->vbasez)
#define vel_objP (sdt->vbasep)
// correction by real speed
#define diff_vA (sdt->diffva)
#define diff_vZ (sdt->diffvz)
#define diff_vP (sdt->diffvp)
// motor speed
#define speedA (sdt->speeda)
#define speedZ (sdt->speedz)
#define speedP (sdt->speedp)
// last precipitation time
#define Precip_time (sdt->m_time_precip)
// reserved
#define Reserve (sdt->reserve)
// real motor speed (''/sec)
#define req_speedA (sdt->rspeeda)
#define req_speedZ (sdt->rspeedz)
#define req_speedP (sdt->rspeedp)
// model speed
#define mod_vel_A (sdt->simvela)
#define mod_vel_Z (sdt->simvelz)
#define mod_vel_P (sdt->simvelp)
#define mod_vel_F (sdt->simvelf)
#define mod_vel_D (sdt->simvelf)
// telescope & hand correction state
/*
* 0x8000 - ÁÚÉÍÕÔ ÐÏÌÏÖÉÔÅÌØÎÙÊ
* 0x4000 - ÏÔÒÁÂÏÔËÁ ×ËÌ.
* 0x2000 - ÒÅÖÉÍ ×ÅÄÅÎÉÑ
* 0x1000 - ÏÔÒÁÂÏÔËÁ P2 ×ËÌ.
* 0x01F0 - ÓË.ËÏÒÒ. 0.2 0.4 1.0 2.0 5.0("/ÓÅË)
* 0x000F - ÎÁÐÒ.ËÏÒÒ. +Z -Z +A -A
*/
#define code_KOST (sdt->kost)
// different time (UTC, stellar, local)
#define M_time (sdt->m_time)
#define S_time (sdt->s_time)
#define L_time (sdt->l_time)
// PPNDD sensor (rough) code
#define ppndd_A (sdt->ppndd_a)
#define ppndd_Z (sdt->ppndd_z)
#define ppndd_P (sdt->ppndd_p)
#define ppndd_B (sdt->ppndd_b) // atm. pressure
// DUP sensor (precise) code (Gray code)
#define dup_A (sdt->dup_a)
#define dup_Z (sdt->dup_z)
#define dup_P (sdt->dup_p)
#define dup_F (sdt->dup_f)
#define dup_D (sdt->dup_d)
// binary 14-digit precise code
#define low_A (sdt->low_a)
#define low_Z (sdt->low_z)
#define low_P (sdt->low_p)
#define low_F (sdt->low_f)
#define low_D (sdt->low_d)
// binary 23-digit rough code
#define code_A (sdt->code_a)
#define code_Z (sdt->code_z)
#define code_P (sdt->code_p)
#define code_B (sdt->code_b)
#define code_F (sdt->code_f)
#define code_D (sdt->code_d)
// ADC PCL818 (8-channel) codes
#define ADC(N) (sdt->adc[(N)])
#define code_T1 ADC(0) // External temperature code
#define code_T2 ADC(1) // In-dome temperature code
#define code_T3 ADC(2) // Mirror temperature code
#define code_Wnd ADC(3) // Wind speed code
// calculated values
#define val_A (sdt->val_a) // A, ''
#define val_Z (sdt->val_z) // Z, ''
#define val_P (sdt->val_p) // P, ''
#define val_B (sdt->val_b) // atm. pressure, mm.hg.
#define val_F (sdt->val_f) // focus, mm
#define val_D (sdt->val_d) // Dome Az, ''
#define val_T1 (sdt->val_t1) // ext. T, degrC
#define val_T2 (sdt->val_t2) // in-dome T, degrC
#define val_T3 (sdt->val_t3) // mirror T, degrC
#define val_Wnd (sdt->val_wnd) // wind speed, m/s
// RA/Decl calculated by A/Z
#define val_Alp (sdt->val_alp)
#define val_Del (sdt->val_del)
// measured speed
#define vel_A (sdt->vel_a)
#define vel_Z (sdt->vel_z)
#define vel_P (sdt->vel_p)
#define vel_F (sdt->vel_f)
#define vel_D (sdt->vel_d)
// system messages queue
#define MesgNum 3
#define MesgLen 39
// message type
enum{
MesgEmpty = 0
,MesgInfor
,MesgWarn
,MesgFault
,MesgLog
};
#define Sys_Mesg(N) (sdt->sys_msg_buf[N])
// access levels
#define code_Lev1 (sdt->code_lev[0]) // remote observer - only information
#define code_Lev2 (sdt->code_lev[1]) // local observer - input coordinates
#define code_Lev3 (sdt->code_lev[2]) // main observer - correction by A/Z, P2/F management
#define code_Lev4 (sdt->code_lev[3]) // operator - start/stop telescope, testing
#define code_Lev5 (sdt->code_lev[4]) // main operator - full access
#define code_Lev(x) (sdt->code_lev[(x-1)])
// network settings
#define NetMask (sdt->netmask) // subnet mask (usually 255.255.255.0)
#define NetWork (sdt->netaddr) // subnet address (for ex.: 192.168.3.0)
#define ACSMask (sdt->acsmask) // ACS network mask (for ex.: 255.255.255.0)
#define ACSNet (sdt->acsaddr) // ACS subnet address (for ex.: 192.168.13.0)
// meteo data
#define MeteoMode (sdt->meteo_stat)
enum{
INPUT_B = 1 // pressure
,INPUT_T1 = 2 // external T
,INPUT_T2 = 4 // in-dome T
,INPUT_T3 = 8 // mirror T
,INPUT_WND = 0x10 // wind speed
,INPUT_HMD = 0x20 // humidity
};
#define SENSOR_B (INPUT_B <<8) // external data flags
#define SENSOR_T1 (INPUT_T1 <<8)
#define SENSOR_T2 (INPUT_T2 <<8)
#define SENSOR_T3 (INPUT_T3 <<8)
#define SENSOR_WND (INPUT_WND<<8)
#define SENSOR_HMD (INPUT_HMD<<8)
#define ADC_B (INPUT_B <<16) // reading from ADC flags
#define ADC_T1 (INPUT_T1 <<16)
#define ADC_T2 (INPUT_T2 <<16)
#define ADC_T3 (INPUT_T3 <<16)
#define ADC_WND (INPUT_WND<<16)
#define ADC_HMD (INPUT_HMD<<16)
#define NET_B (INPUT_B <<24) // got by network flags
#define NET_T1 (INPUT_T1 <<24)
#define NET_WND (INPUT_WND<<24)
#define NET_HMD (INPUT_HMD<<24)
// input meteo values
#define inp_B (sdt->inp_b) // atm.pressure (mm.hg)
#define inp_T1 (sdt->inp_t1) // ext T
#define inp_T2 (sdt->inp_t2) // in-dome T
#define inp_T3 (sdt->inp_t3) // mirror T
#define inp_Wnd (sdt->inp_wnd) // wind
// values used for refraction calculation
#define Temper (sdt->temper)
#define Pressure (sdt->press)
// last wind gust time
#define Wnd10_time (sdt->m_time10)
#define Wnd15_time (sdt->m_time15)
// IERS DUT1
#define DUT1 (sdt->dut1)
// sensors reading time
#define A_time (sdt->a_time)
#define Z_time (sdt->z_time)
#define P_time (sdt->p_time)
// input speeds
#define speedAin (sdt->speedain)
#define speedZin (sdt->speedzin)
#define speedPin (sdt->speedpin)
// acceleration (''/sec^2)
#define acc_A (sdt->acc_a)
#define acc_Z (sdt->acc_z)
#define acc_P (sdt->acc_p)
#define acc_F (sdt->acc_f)
#define acc_D (sdt->acc_d)
// SEW code
#define code_SEW (sdt->code_sew)
// sew data
#define statusSEW(Drv) (sdt->sewdrv[(Drv)-1].status)
#define statusSEW1 (sdt->sewdrv[0].status)
#define statusSEW2 (sdt->sewdrv[1].status)
#define statusSEW3 (sdt->sewdrv[2].status)
#define speedSEW(Drv) (sdt->sewdrv[(Drv)-1].set_speed)
#define speedSEW1 (sdt->sewdrv[0].set_speed)
#define speedSEW2 (sdt->sewdrv[1].set_speed)
#define speedSEW3 (sdt->sewdrv[2].set_speed)
#define vel_SEW(Drv) (sdt->sewdrv[(Drv)-1].mes_speed)
#define vel_SEW1 (sdt->sewdrv[0].mes_speed)
#define vel_SEW2 (sdt->sewdrv[1].mes_speed)
#define vel_SEW3 (sdt->sewdrv[2].mes_speed)
#define currentSEW(Drv) (sdt->sewdrv[(Drv)-1].current)
#define currentSEW1 (sdt->sewdrv[0].current)
#define currentSEW2 (sdt->sewdrv[1].current)
#define currentSEW3 (sdt->sewdrv[2].current)
#define indexSEW(Drv) (sdt->sewdrv[(Drv)-1].index)
#define indexSEW1 (sdt->sewdrv[0].index)
#define indexSEW2 (sdt->sewdrv[1].index)
#define indexSEW3 (sdt->sewdrv[2].index)
#define valueSEW(Drv) (sdt->sewdrv[(Drv)-1].value.l)
#define valueSEW1 (sdt->sewdrv[0].value.l)
#define valueSEW2 (sdt->sewdrv[1].value.l)
#define valueSEW3 (sdt->sewdrv[2].value.l)
#define bvalSEW(Drv,Nb) (sdt->sewdrv[(Drv)-1].value.b[Nb])
// 23-digit PEP-controllers code
#define PEP_code_A (sdt->pep_code_a)
#define PEP_code_Z (sdt->pep_code_z)
#define PEP_code_P (sdt->pep_code_p)
// PEP end-switches code
#define switch_A (sdt->pep_sw_a)
enum{
Sw_minus_A = 1 // negative A value
,Sw_plus240_A = 2 // end switch +240degr
,Sw_minus240_A = 4 // end switch -240degr
,Sw_minus45_A = 8 // "horizon" end switch
};
#define switch_Z (sdt->pep_sw_z)
enum{
Sw_0_Z = 1
,Sw_5_Z = 2
,Sw_20_Z = 4
,Sw_60_Z = 8
,Sw_80_Z = 0x10
,Sw_90_Z = 0x20
};
#define switch_P (sdt->pep_sw_p)
enum{
Sw_No_P = 0 // no switches
,Sw_22_P = 1 // 22degr
,Sw_89_P = 2 // 89degr
,Sw_Sm_P = 0x80 // Primary focus smoke sensor
};
// PEP codes
#define PEP_code_F (sdt->pep_code_f)
#define PEP_code_D (sdt->pep_code_d)
#define PEP_code_Rin (sdt->pep_code_ri)
#define PEP_code_Rout (sdt->pep_code_ro)
// PEP flags
#define PEP_A_On (sdt->pep_on[0])
#define PEP_A_Off (PEP_A_On==0)
#define PEP_Z_On (sdt->pep_on[1])
#define PEP_Z_Off (PEP_Z_On==0)
#define PEP_P_On (sdt->pep_on[2])
#define PEP_P_Off (PEP_P_On==0)
#define PEP_F_On (sdt->pep_on[3])
#define PEP_F_Off (PEP_F_On==0)
#define PEP_D_On (sdt->pep_on[4])
#define PEP_D_Off (PEP_D_On==0)
#define PEP_R_On (sdt->pep_on[5])
#define PEP_R_Off ((PEP_R_On&1)==0)
#define PEP_R_Inp ((PEP_R_On&2)!=0)
#define PEP_K_On (sdt->pep_on[6])
#define PEP_K_Off ((PEP_K_On&1)==0)
#define PEP_K_Inp ((PEP_K_On&2)!=0)
// IERS polar motion
#define polarX (sdt->xpol)
#define polarY (sdt->ypol)
// current Julian date, sidereal time correction by "Equation of the Equinoxes"
#define JDate (sdt->jdate)
#define EE_time (sdt->eetime)
// humidity value (%%) & hand input
#define val_Hmd (sdt->val_hmd)
#define inp_Hmd (sdt->val_hmd)
// worm position, mkm
#define worm_A (sdt->worm_a)
#define worm_Z (sdt->worm_z)
// locking flags
#define LockFlags (sdt->lock_flags)
enum{
Lock_A = 1
,Lock_Z = 2
,Lock_P = 4
,Lock_F = 8
,Lock_D = 0x10
};
#define A_Locked (LockFlags&Lock_A)
#define Z_Locked (LockFlags&Lock_Z)
#define P_Locked (LockFlags&Lock_P)
#define F_Locked (LockFlags&Lock_F)
#define D_Locked (LockFlags&Lock_D)
// SEW dome divers speed
#define Dome_Speed (sdt->sew_dome_speed)
// SEW dome drive number (for indication)
#define DomeSEW_N (sdt->sew_dome_num)
// SEW dome driver parameters
#define statusSEWD (sdt->sewdomedrv.status) // controller status
#define speedSEWD (sdt->sewdomedrv.set_speed) // speed, rpm
#define vel_SEWD (sdt->sewdomedrv.mes_speed) /*ÉÚÍÅÒÅÎÎÁÑ ÓËÏÒÏÓÔØ ÏÂ/ÍÉÎ (rpm)*/
#define currentSEWD (sdt->sewdomedrv.current) // current, A
#define indexSEWD (sdt->sewdomedrv.index) // parameter index
#define valueSEWD (sdt->sewdomedrv.value.l) // parameter value
// dome PEP codes
#define PEP_code_Din (sdt->pep_code_di) // data in
#define PEP_Dome_SEW_Ok 0x200
#define PEP_Dome_Cable_Ok 0x100
#define PEP_code_Dout (sdt->pep_code_do) // data out
#define PEP_Dome_SEW_On 0x10
#define PEP_Dome_SEW_Off 0x20
/*******************************************************************************
* BTA data structure *
*******************************************************************************/
#define BTA_Data_Ver 2
struct BTA_Data {
int32_t magic; // magic value
int32_t version; // BTA_Data_Ver
int32_t size; // sizeof(struct BTA_Data)
int32_t pid; // main process PID
int32_t model; // model modes
int32_t timer; // timer selected
int32_t system; // main system mode
int32_t sys_target; // system pointing target
int32_t tel_focus; // telescope focus type
double pc_coeff[8]; // pointing correction system coefficients
int32_t tel_state; // telescope state
int32_t req_state; // new (required) state
int32_t tel_hard_state; // Power state
int32_t tel_mode; // telescope mode
int32_t az_mode; // azimuth reverce
int32_t p2_state; // P2 motor state
int32_t p2_req_mode; // P2 required state
int32_t focus_state; // focus motor state
int32_t dome_state; // dome motors state
int32_t pcor_mode; // pointing correction mode
int32_t trkok_mode; // tracking mode
double i_alpha, i_delta; // input values
double s_alpha, s_delta; // source
double v_alpha, v_delta; // intrinsic vel.
double i_azim, i_zdist; // input A/Z
double c_alpha, c_delta; // calculated values
double tag_a, tag_z, tag_p; // current values (from sensors)
double pcor_a, pcor_z, refr_z; // calculated corrections
double tcor_a, tcor_z, tref_z; // reverse calculation corr.
double diff_a, diff_z, diff_p; // coords difference
double vbasea,vbasez,vbasep; // base object velocity
double diffva,diffvz,diffvp; // correction by real speed
double speeda,speedz,speedp; // motor speed
double m_time_precip; // last precipitation time
uint8_t reserve[16]; // reserved
double rspeeda, rspeedz, rspeedp; // real motor speed (''/sec)
double simvela, simvelz, simvelp, simvelf, simveld; // model speed
uint32_t kost; // telescope & hand correction state
double m_time, s_time, l_time; // different time (UTC, stellar, local)
uint32_t ppndd_a, ppndd_z, ppndd_p, ppndd_b; // PPNDD sensor (rough) code
uint32_t dup_a, dup_z, dup_p, dup_f, dup_d; // DUP sensor (precise) code (Gray code)
uint32_t low_a, low_z, low_p, low_f, low_d; // binary 14-digit precise code
uint32_t code_a, code_z, code_p, code_b, code_f, code_d; // binary 23-digit rough code
uint32_t adc[8]; // ADC PCL818 (8-channel) codes
double val_a, val_z, val_p, val_b, val_f, val_d;
double val_t1, val_t2, val_t3, val_wnd; // calculated values
double val_alp, val_del; // RA/Decl calculated by A/Z
double vel_a, vel_z, vel_p, vel_f, vel_d; // measured speed
// system messages queue
struct SysMesg {
int32_t seq_num;
char type; // message type
char text[MesgLen]; // message itself
} sys_msg_buf[MesgNum];
// access levels
uint32_t code_lev[5];
// network settings
uint32_t netmask, netaddr, acsmask, acsaddr;
int32_t meteo_stat; // meteo data
double inp_b, inp_t1, inp_t2, inp_t3, inp_wnd; // input meteo values
double temper, press; // values used for refraction calculation
double m_time10, m_time15; // last wind gust time
double dut1; // IERS DUT1 (src: ftp://maia.usno.navy.mil/ser7/ser7.dat), DUT1 = UT1-UTC
double a_time, z_time, p_time; // sensors reading time
double speedain, speedzin, speedpin; // input speeds
double acc_a, acc_z, acc_p, acc_f, acc_d; // acceleration (''/sec^2)
uint32_t code_sew; // SEW code
struct SEWdata { // sew data
int32_t status;
double set_speed; // target speed, rpm
double mes_speed; // measured speed, rpm
double current; // measured current, A
int32_t index; // parameter number
union{ // parameter code
uint8_t b[4];
uint32_t l;
} value;
} sewdrv[3];
uint32_t pep_code_a, pep_code_z, pep_code_p; // 23-digit PEP-controllers code
uint32_t pep_sw_a, pep_sw_z, pep_sw_p; // PEP end-switches code
uint32_t pep_code_f, pep_code_d, pep_code_ri, pep_code_ro; // PEP codes
uint8_t pep_on[10]; // PEP flags
double xpol, ypol; // IERS polar motion (src: ftp://maia.usno.navy.mil/ser7/ser7.dat)
double jdate, eetime; // current Julian date, sidereal time correction by "Equation of the Equinoxes"
double val_hmd, inp_hmd; // humidity value (%%) & hand input
double worm_a, worm_z; // worm position, mkm
/* ÆÌÁÇÉ ÂÌÏËÉÒÏ×ËÉ ÕÐÒÁ×ÌÅÎÉÑ ÕÚÌÁÍÉ */
uint32_t lock_flags; // locking flags
int32_t sew_dome_speed; // SEW dome divers speed: D_Lplus, D_Hminus etc
int32_t sew_dome_num; // SEW dome drive number (for indication)
struct SEWdata sewdomedrv; // SEW dome driver parameters
uint32_t pep_code_di, pep_code_do; // dome PEP codes
};
extern struct BTA_Data *sdt;
/*******************************************************************************
* Local data structure *
*******************************************************************************/
// Oil pressure, MPa
#define PressOilA (sdtl->pr_oil_a)
#define PressOilZ (sdtl->pr_oil_z)
#define PressOilTank (sdtl->pr_oil_t)
// Oil themperature, degrC
#define OilTemper1 (sdtl->t_oil_1) // oil
#define OilTemper2 (sdtl->t_oil_2) // water
// Local data structure
struct BTA_Local {
uint8_t reserve[120]; // reserved data
double pr_oil_a,pr_oil_z,pr_oil_t; // Oil pressure
double t_oil_1,t_oil_2; // Oil themperature
};
/**
* Message buffer structure
*/
struct my_msgbuf {
int32_t mtype; // message type
uint32_t acckey; // client access key
uint32_t src_pid; // source PID
uint32_t src_ip; // IP of command source or 0 for local
char mtext[100]; // message itself
};
extern struct BTA_Local *sdtl;
extern int snd_id;
extern int cmd_src_pid;
extern uint32_t cmd_src_ip;
#define ClientSide 0
#define ServerSide 1
#ifndef BTA_MODULE
void bta_data_init();
int bta_data_check();
void bta_data_close();
int get_shm_block( struct SHM_Block *sb, int server);
int close_shm_block(struct SHM_Block *sb);
void get_cmd_queue( struct CMD_Queue *cq, int server);
#endif
int check_shm_block( struct SHM_Block *sb);
void encode_lev_passwd(char *passwd, int nlev, uint32_t *keylev, uint32_t *codlev);
int find_lev_passwd(char *passwd, uint32_t *keylev, uint32_t *codlev);
int check_lev_passwd(char *passwd);
void set_acckey(uint32_t newkey);
// restore packing
#pragma pack(pop)
//#pragma GCC diagnostic pop
#endif // __BTA_SHDATA_H__

140
ch4run.c Normal file
View File

@ -0,0 +1,140 @@
/*
* ch4run.c - functions for checking whether this process already run
*
* Copyright 2013 Edward V. Emelianoff <eddy@sao.ru>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#include "ch4run.h"
#include <stdio.h> // printf, fopen, ...
#include <unistd.h> // getpid
#include <stdio.h> // perror
#include <sys/types.h> // opendir
#include <dirent.h> // opendir
#include <sys/stat.h> // stat
#include <fcntl.h> // fcntl
#include <stdlib.h> // exit
#include <string.h> // memset
/**
* read process name from /proc/PID/cmdline
* @param pid - PID of interesting process
* @return filename or NULL if not found
* don't use this function twice for different names without copying
* its returning by strdup, because `name` contains in static array
*/
char *readname(pid_t pid){
static char name[256];
char *pp = name, byte, path[256];
FILE *file;
int cntr = 0;
size_t sz;
snprintf (path, 255, PROC_BASE "/%d/cmdline", pid);
file = fopen(path, "r");
if(!file) return NULL; // there's no such file
do{ // read basename
sz = fread(&byte, 1, 1, file);
if(sz != 1) break;
if(byte != '/') *pp++ = byte;
else{
pp = name;
cntr = 0;
}
}while(byte && cntr++ < 255);
name[cntr] = 0;
fclose(file);
return name;
}
void iffound_default(pid_t pid){
fprintf(stderr, "\nFound running process (pid=%d), exit.\n", pid);
exit(0);
}
/**
* check wether there is a same running process
* exit if there is a running process or error
* Checking have 3 steps:
* 1) lock executable file
* 2) check pidfile (if you run a copy?)
* 3) check /proc for executables with the same name (no/wrong pidfile)
* @param argv - argument of main() or NULL for non-locking, call this function before getopt()
* @param pidfilename - name of pidfile or NULL if none
* @param iffound - action to run if file found or NULL for exit(0)
*/
void check4running(char **argv, char *pidfilename, void (*iffound)(pid_t pid)){
DIR *dir;
FILE *pidfile, *fself;
struct dirent *de;
struct stat s_buf;
pid_t pid = 0, self;
struct flock fl;
char *name, *myname;
if(!iffound) iffound = iffound_default;
if(argv){ // block self
fself = fopen(argv[0], "r"); // open self binary to lock
memset(&fl, 0, sizeof(struct flock));
fl.l_type = F_WRLCK;
if(fcntl(fileno(fself), F_GETLK, &fl) == -1){ // check locking
perror("fcntl");
exit(1);
}
if(fl.l_type != F_UNLCK){ // file is locking - exit
printf("Found locker, PID = %d!\n", fl.l_pid);
exit(1);
}
fl.l_type = F_RDLCK;
if(fcntl(fileno(fself), F_SETLKW, &fl) == -1){
perror("fcntl");
exit(1);
}
}
self = getpid(); // get self PID
if(!(dir = opendir(PROC_BASE))){ // open /proc directory
perror(PROC_BASE);
exit(1);
}
if(!(name = readname(self))){ // error reading self name
perror("Can't read self name");
exit(1);
}
myname = strdup(name);
if(pidfilename && stat(pidfilename, &s_buf) == 0){ // pidfile exists
pidfile = fopen(pidfilename, "r");
if(pidfile){
if(fscanf(pidfile, "%d", &pid) > 0){ // read PID of (possibly) running process
if((name = readname(pid)) && strncmp(name, myname, 255) == 0)
iffound(pid);
}
fclose(pidfile);
}
}
// There is no pidfile or it consists a wrong record
while((de = readdir(dir))){ // scan /proc
if(!(pid = (pid_t)atoi(de->d_name)) || pid == self) // pass non-PID files and self
continue;
if((name = readname(pid)) && strncmp(name, myname, 255) == 0)
iffound(pid);
}
closedir(dir);
if(pidfilename){
pidfile = fopen(pidfilename, "w");
fprintf(pidfile, "%d\n", self); // write self PID to pidfile
fclose(pidfile);
}
free(myname);
}

28
ch4run.h Normal file
View File

@ -0,0 +1,28 @@
/*
* daemon.h
*
* Copyright 2015 Edward V. Emelianov <eddy@sao.ru, edward.emelianoff@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#ifndef PROC_BASE
#define PROC_BASE "/proc"
#endif
#include <unistd.h> // pid_t
void iffound_default(pid_t pid);
void check4running(char **argv, char *pidfilename, void (*iffound)(pid_t pid));

109
cmdlnopts.c Normal file
View File

@ -0,0 +1,109 @@
/*
* cmdlnopts.c - the only function that parce cmdln args and returns glob parameters
*
* Copyright 2013 Edward V. Emelianoff <eddy@sao.ru>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#include "cmdlnopts.h"
#include "usefull_macros.h"
#include <assert.h>
/*
* here are global parameters initialisation
*/
glob_pars G; // internal global parameters structure
int help = 0; // whether to show help string
glob_pars Gdefault = {
.passfile = NULL
,.force = 0
,.p2move = NULL
,.p2mode = NULL
,.focmove = -1.
,.eqcrds = NULL
,.horcrds = NULL
,.azrev = 0
,.telstop = 0
,.gotoRaDec = 0
,.gotoAZ = 0
,.epoch = NULL
,.pmra = 0.
,.pmdecl = 0.
,.PCSoff = 0
,.corrAZ = 0
,.corrRAD = 0
,.quiet = 0
,.getinfo = NULL
,.infoargs = NULL
,.listinfo = 0
};
/*
* Define command line options by filling structure:
* name has_arg flag val type argptr help
*/
myoption cmdlnopts[] = {
{"help", 0, NULL, 'h', arg_int, APTR(&help), N_("show this help")},
{"passfile",1, NULL, 'p', arg_string, APTR(&G.passfile), N_("file with password hash (in/out)")},
{"force", 0, NULL, 'f', arg_int, APTR(&G.force), N_("force command executions")},
{"p2move", 1, NULL, 'P', arg_string, APTR(&G.p2move), N_("move P2 (arg: angle[rel])")},
{"p2mode", 1, NULL, 'M', arg_string, APTR(&G.p2mode), N_("set P2 mode (arg: stop/track)")},
{"focmove", 1, NULL, 'F', arg_double, APTR(&G.focmove), N_("move focus to given value")},
{"eq-crds", 1, NULL, 'e', arg_string, APTR(&G.eqcrds), N_("set new equatorial coordinates")},
{"hor-crds",1, NULL, 'a', arg_string, APTR(&G.horcrds), N_("set new horizontal coordinates")},
{"az-reverce",0,NULL, 'R', arg_int, APTR(&G.azrev), N_("switch Az reverce")},
{"stop-tel",0, NULL, 'S', arg_int, APTR(&G.telstop), N_("stop telescope")},
{"gotoradec",0, NULL, 'G', arg_int, APTR(&G.gotoRaDec), N_("go to last entered RA/Decl")},
{"gotoaz", 0, NULL, 'A', arg_int, APTR(&G.gotoAZ), N_("go to last entered A/Z")},
{"epoch", 2, NULL, 'E', arg_string, APTR(&G.epoch), N_("epoch for given RA/Decl (without argument is \"now\")")},
{"pm-ra", 1, NULL, 'x', arg_double, APTR(&G.pmra), N_("proper motion by R.A. (mas/year)")},
{"pm-decl", 1, NULL, 'y', arg_double, APTR(&G.pmdecl), N_("proper motion by Decl. (mas/year)")},
{"pcs-off", 0, NULL, 'O', arg_int, APTR(&G.PCSoff), N_("turn OFF pointing correction system")},
{"az-corr", 1, NULL, 1, arg_string, APTR(&G.corrAZ), N_("run correction by A/Z (arg in arcsec: dA,dZ)")},
{"rad-corr",1, NULL, 1, arg_string, APTR(&G.corrRAD), N_("run correction by RA/Decl (arg in arcsec: dRA,dDecl)")},
{"quiet", 0, NULL, 'q', arg_int, APTR(&G.quiet), N_("almost no messages into stdout")},
{"get-info",2, NULL, 'I', arg_string, APTR(&G.getinfo), N_("show information (default: all, \"help\" for list)")},
{"info-args",1, NULL, 'i', arg_string, APTR(&G.infoargs), N_("show values of given ACS parameters")},
{"list-info",0, NULL, 'l', arg_string, APTR(&G.listinfo), N_("list all ACS parameters available")},
// ...
end_option
};
/**
* Parce command line options and return dynamically allocated structure
* to global parameters
* @param argc - copy of argc from main
* @param argv - copy of argv from main
* @return allocated structure with global parameters
*/
glob_pars *parce_args(int argc, char **argv){
int i;
void *ptr;
ptr = memcpy(&G, &Gdefault, sizeof(G)); assert(ptr);
// format of help: "Usage: progname [args]\n"
change_helpstring("Usage: %s [args]\n\n\tWhere args are:\n");
// parse arguments
parceargs(&argc, &argv, cmdlnopts);
if(help) showhelp(-1, cmdlnopts);
if(argc > 0){
printf("\nIgnore argument[s]:\n");
for (i = 0; i < argc; i++)
printf("\t%s\n", argv[i]);
}
return &G;
}

59
cmdlnopts.h Normal file
View File

@ -0,0 +1,59 @@
/*
* cmdlnopts.h - comand line options for parceargs
*
* Copyright 2013 Edward V. Emelianoff <eddy@sao.ru>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#pragma once
#ifndef __CMDLNOPTS_H__
#define __CMDLNOPTS_H__
#include "parceargs.h"
/*
* here are some typedef's for global data
*/
typedef struct{
char *passfile; // filename with password
int force; // force command running (stop p2 if moving etc)
char *p2move; // rotate p2 arguments: angle[rel]
char *p2mode; // set P2 mode (stop/track)
double focmove; // move focus to given value
char *eqcrds; // set new equatorial coordinates
char *horcrds; // set new horizontal coordinates
int azrev; // reverse A/Z
int telstop; // stop telescope
int gotoRaDec; // goto last entered RA/Decl
int gotoAZ; // goto last entered A/Z
char *epoch; // epoch for given coordinates (vararg: year or "now" if present, "now" if absent)
double pmra; // proper motion by R.A. (mas/year)
double pmdecl; // proper motion by Decl (mas/year)
int PCSoff; // turn OFF PCS for current moving
char *corrAZ; // run correction by A/Z
char *corrRAD; // run correction by RA/Decl
int quiet; // ==1 - no messages to stdout
char *getinfo; // level of requested information (meteo, coords, etc)
char *infoargs; // list of requested information (certain parameters)
int listinfo; // show list of information parameters available
}glob_pars;
glob_pars *parce_args(int argc, char **argv);
extern glob_pars *GP;
#endif // __CMDLNOPTS_H__

297
parceargs.c Normal file
View File

@ -0,0 +1,297 @@
/*
* parceargs.c - parcing command line arguments & print help
*
* Copyright 2013 Edward V. Emelianoff <eddy@sao.ru>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#include <stdio.h> // DBG
#include <getopt.h> // getopt_long
#include <stdlib.h> // calloc, exit, strtoll
#include <assert.h> // assert
#include <string.h> // strdup, strchr, strlen
#include <limits.h> // INT_MAX & so on
#include <libintl.h>// gettext
#include <ctype.h> // isalpha
#include <stdlib.h> // strtoll
#include "parceargs.h"
// macro to print help messages
#ifndef PRNT
#define PRNT(x) gettext(x)
#endif
char *helpstring = "%s\n";
/**
* Change standard help header
* MAY consist ONE "%s" for progname
* @param str (i) - new format
*/
void change_helpstring(char *s){
int pcount = 0, scount = 0;
char *str = s;
// check `helpstring` and set it to default in case of error
for(; pcount < 2; str += 2){
if(!(str = strchr(str, '%'))) break;
if(str[1] != '%') pcount++; // increment '%' counter if it isn't "%%"
else{
str += 2; // pass next '%'
continue;
}
if(str[1] == 's') scount++; // increment "%s" counter
};
if(pcount > 1 || pcount != scount){ // amount of pcount and/or scount wrong
fprintf(stderr, "Wrong helpstring!\n");
exit(-1);
}
helpstring = s;
}
/**
* Carefull atoll/atoi
* @param num (o) - returning value (or NULL if you wish only check number) - allocated by user
* @param str (i) - string with number must not be NULL
* @param t (i) - T_INT for integer or T_LLONG for long long (if argtype would be wided, may add more)
* @return TRUE if conversion sone without errors, FALSE otherwise
*/
static bool myatoll(void *num, char *str, argtype t){
long long tmp, *llptr;
int *iptr;
char *endptr;
assert(str);
assert(num);
tmp = strtoll(str, &endptr, 0);
if(endptr == str || *str == '\0' || *endptr != '\0')
return FALSE;
switch(t){
case arg_longlong:
llptr = (long long*) num;
*llptr = tmp;
break;
case arg_int:
default:
if(tmp < INT_MIN || tmp > INT_MAX){
fprintf(stderr, "Integer out of range\n");
return FALSE;
}
iptr = (int*)num;
*iptr = (int)tmp;
}
return TRUE;
}
// the same as myatoll but for double
// There's no NAN & INF checking here (what if they would be needed?)
static bool myatod(void *num, const char *str, argtype t){
double tmp, *dptr;
float *fptr;
char *endptr;
assert(str);
tmp = strtod(str, &endptr);
if(endptr == str || *str == '\0' || *endptr != '\0')
return FALSE;
switch(t){
case arg_double:
dptr = (double *) num;
*dptr = tmp;
break;
case arg_float:
default:
fptr = (float *) num;
*fptr = (float)tmp;
break;
}
return TRUE;
}
/**
* Get index of current option in array options
* @param opt (i) - returning val of getopt_long
* @param options (i) - array of options
* @return index in array
*/
int get_optind(int opt, myoption *options){
int oind;
myoption *opts = options;
assert(opts);
for(oind = 0; opts->name && opts->val != opt; oind++, opts++);
if(!opts->name || opts->val != opt) // no such parameter
showhelp(-1, options);
return oind;
}
/**
* Parce command line arguments
* ! If arg is string, then value will be strdup'ed!
*
* @param argc (io) - address of argc of main(), return value of argc stay after `getopt`
* @param argv (io) - address of argv of main(), return pointer to argv stay after `getopt`
* BE CAREFUL! if you wanna use full argc & argv, save their original values before
* calling this function
* @param options (i) - array of `myoption` for arguments parcing
*
* @exit: in case of error this function show help & make `exit(-1)`
*/
void parceargs(int *argc, char ***argv, myoption *options){
char *short_options, *soptr;
struct option *long_options, *loptr;
size_t optsize, i;
myoption *opts = options;
// check whether there is at least one options
assert(opts);
assert(opts[0].name);
// first we count how much values are in opts
for(optsize = 0; opts->name; optsize++, opts++);
// now we can allocate memory
short_options = calloc(optsize * 3 + 1, 1); // multiply by three for '::' in case of args in opts
long_options = calloc(optsize + 1, sizeof(struct option));
opts = options; loptr = long_options; soptr = short_options;
// fill short/long parameters and make a simple checking
for(i = 0; i < optsize; i++, loptr++, opts++){
// check
assert(opts->name); // check name
if(opts->has_arg){
assert(opts->type != arg_none); // check error with arg type
assert(opts->argptr); // check pointer
}
if(opts->type != arg_none) // if there is a flag without arg, check its pointer
assert(opts->argptr);
// fill long_options
// don't do memcmp: what if there would be different alignment?
loptr->name = opts->name;
loptr->has_arg = opts->has_arg;
loptr->flag = opts->flag;
loptr->val = opts->val;
// fill short options if they are:
if(!opts->flag){
*soptr++ = opts->val;
if(opts->has_arg) // add ':' if option has required argument
*soptr++ = ':';
if(opts->has_arg == 2) // add '::' if option has optional argument
*soptr++ = ':';
}
}
// now we have both long_options & short_options and can parse `getopt_long`
while(1){
int opt;
int oindex = 0, optind = 0; // oindex - number of option in argv, optind - number in options[]
if((opt = getopt_long(*argc, *argv, short_options, long_options, &oindex)) == -1) break;
if(opt == '?'){
opt = optopt;
optind = get_optind(opt, options);
if(options[optind].has_arg == 1) showhelp(optind, options); // need argument
}
else{
if(opt == 0 || oindex > 0) optind = oindex;
else optind = get_optind(opt, options);
}
opts = &options[optind];
if(opt == 0 && opts->has_arg == 0) continue; // only long option changing integer flag
// now check option
if(opts->has_arg == 1) assert(optarg);
bool result = TRUE;
// even if there is no argument, but argptr != NULL, think that optarg = "1"
if(!optarg) optarg = "1";
switch(opts->type){
default:
case arg_none:
if(opts->argptr) *((int*)opts->argptr) = 1; // set argptr to 1
break;
case arg_int:
result = myatoll(opts->argptr, optarg, arg_int);
break;
case arg_longlong:
result = myatoll(opts->argptr, optarg, arg_longlong);
break;
case arg_double:
result = myatod(opts->argptr, optarg, arg_double);
break;
case arg_float:
result = myatod(opts->argptr, optarg, arg_float);
break;
case arg_string:
result = (*((char **)opts->argptr) = strdup(optarg));
break;
case arg_function:
result = ((argfn)opts->argptr)(optarg, optind);
break;
}
if(!result){
showhelp(optind, options);
}
}
*argc -= optind;
*argv += optind;
}
/**
* Show help information based on myoption->help values
* @param oindex (i) - if non-negative, show only help by myoption[oindex].help
* @param options (i) - array of `myoption`
*
* @exit: run `exit(-1)` !!!
*/
void showhelp(int oindex, myoption *options){
// ATTENTION: string `help` prints through macro PRNT(), by default it is gettext,
// but you can redefine it before `#include "parceargs.h"`
int max_opt_len = 0; // max len of options substring - for right indentation
const int bufsz = 255;
char buf[bufsz+1];
myoption *opts = options;
assert(opts);
assert(opts[0].name); // check whether there is at least one options
if(oindex > -1){ // print only one message
opts = &options[oindex];
printf(" ");
if(!opts->flag && isalpha(opts->val)) printf("-%c, ", opts->val);
printf("--%s", opts->name);
if(opts->has_arg == 1) printf("=arg");
else if(opts->has_arg == 2) printf("[=arg]");
printf(" %s\n", PRNT(opts->help));
exit(-1);
}
// header, by default is just "progname\n"
printf("\n");
if(strstr(helpstring, "%s")) // print progname
printf(helpstring, __progname);
else // only text
printf("%s", helpstring);
printf("\n");
// count max_opt_len
do{
int L = strlen(opts->name);
if(max_opt_len < L) max_opt_len = L;
}while((++opts)->name);
max_opt_len += 15; // format: '-S , --long[=arg]' - get addition 14 symbols
opts = options;
// Now print all help
do{
int p = sprintf(buf, " "); // a little indent
if(!opts->flag && isalpha(opts->val)) // .val is short argument
p += snprintf(buf+p, bufsz-p, "-%c, ", opts->val);
p += snprintf(buf+p, bufsz-p, "--%s", opts->name);
if(opts->has_arg == 1) // required argument
p += snprintf(buf+p, bufsz-p, "=arg");
else if(opts->has_arg == 2) // optional argument
p += snprintf(buf+p, bufsz-p, "[=arg]");
assert(p <= max_opt_len); // there would be magic if p > max_opt_len
printf("%-*s%s\n", max_opt_len+1, buf, PRNT(opts->help)); // write options & at least 2 spaces after
}while((++opts)->name);
printf("\n\n");
exit(-1);
}

105
parceargs.h Normal file
View File

@ -0,0 +1,105 @@
/*
* parceargs.h - headers for parcing command line arguments
*
* Copyright 2013 Edward V. Emelianoff <eddy@sao.ru>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*/
#pragma once
#ifndef __PARCEARGS_H__
#define __PARCEARGS_H__
#include <stdbool.h>// bool
#include <stdlib.h>
#ifndef TRUE
#define TRUE true
#endif
#ifndef FALSE
#define FALSE false
#endif
// macro for argptr
#define APTR(x) ((void*)x)
// if argptr is a function:
typedef bool(*argfn)(void *arg, int N);
/*
* type of getopt's argument
* WARNING!
* My function change value of flags by pointer, so if you want to use another type
* make a latter conversion, example:
* char charg;
* int iarg;
* myoption opts[] = {
* {"value", 1, NULL, 'v', arg_int, &iarg, "char val"}, ..., end_option};
* ..(parce args)..
* charg = (char) iarg;
*/
typedef enum {
arg_none = 0, // no arg
arg_int, // integer
arg_longlong, // long long
arg_double, // double
arg_float, // float
arg_string, // char *
arg_function // parce_args will run function `bool (*fn)(char *optarg, int N)`
} argtype;
/*
* Structure for getopt_long & help
* BE CAREFUL: .argptr is pointer to data or pointer to function,
* conversion depends on .type
*
* ATTENTION: string `help` prints through macro PRNT(), bu default it is gettext,
* but you can redefine it before `#include "parceargs.h"`
*
* if arg is string, then value wil be strdup'ed like that:
* char *str;
* myoption opts[] = {{"string", 1, NULL, 's', arg_string, &str, "string val"}, ..., end_option};
* *(opts[1].str) = strdup(optarg);
* in other cases argptr should be address of some variable (or pointer to allocated memory)
*
* NON-NULL argptr should be written inside macro APTR(argptr) or directly: (void*)argptr
*
* !!!LAST VALUE OF ARRAY SHOULD BE `end_option` or ZEROS !!!
*
*/
typedef struct{
// these are from struct option:
const char *name; // long option's name
int has_arg; // 0 - no args, 1 - nesessary arg, 2 - optionally arg
int *flag; // NULL to return val, pointer to int - to set its value of val (function returns 0)
int val; // short opt name (if flag == NULL) or flag's value
// and these are mine:
argtype type; // type of argument
void *argptr; // pointer to variable to assign optarg value or function `bool (*fn)(char *optarg, int N)`
char *help; // help string which would be shown in function `showhelp` or NULL
} myoption;
// last string of array (all zeros)
#define end_option {0,0,0,0,0,0,0}
extern const char *__progname;
void showhelp(int oindex, myoption *options);
void parceargs(int *argc, char ***argv, myoption *options);
void change_helpstring(char *s);
#endif // __PARCEARGS_H__

44
slalib/Makefile Normal file
View File

@ -0,0 +1,44 @@
# Makefile for SLALIB
# for Pentium/Linux
# by Scott M. Ransom
# OS type
OS = Linux
#OS = OSX
# Linux is the first choice
ifeq ($(OS),Linux)
LIBSUFFIX = .so
LIBCMD = -shared
SYSDIR = /usr
LOCDIR = /usr/local
# else assume Darwin (i.e. OSX)
else
LIBSUFFIX = .dylib
LIBCMD = -dynamiclib
SYSDIR = /sw
LOCDIR = /sw
endif
CC = gcc
FC = gfortran
#FC = g77
CFLAGS = -O2 -Wall -W -fPIC
CLINKFLAGS = $(CFLAGS)
FFLAGS = -O2 -fPIC
FLINKFLAGS = $(FFLAGS)
all: libsla
libsla:
$(FC) $(FFLAGS) -fno-underscoring -c -I. *.f *.F
$(FC) $(LIBCMD) -o libsla$(LIBSUFFIX) -fno-underscoring *.o
install:
cp slalib.h slamac.h /usr/include
cp libsla.so /usr/lib
clean:
rm -f *.o *~ *#
rm -rf build

6
slalib/README Normal file
View File

@ -0,0 +1,6 @@
clone of https://github.com/scottransom/pyslalib.git with deleted unnesessary files
just do make && su -c "make install"
don't use header file slalib.h still it's wrong

84
slalib/addet.f Normal file
View File

@ -0,0 +1,84 @@
SUBROUTINE sla_ADDET (RM, DM, EQ, RC, DC)
*+
* - - - - - -
* A D D E T
* - - - - - -
*
* Add the E-terms (elliptic component of annual aberration)
* to a pre IAU 1976 mean place to conform to the old
* catalogue convention (double precision)
*
* Given:
* RM,DM dp RA,Dec (radians) without E-terms
* EQ dp Besselian epoch of mean equator and equinox
*
* Returned:
* RC,DC dp RA,Dec (radians) with E-terms included
*
* Note:
*
* Most star positions from pre-1984 optical catalogues (or
* derived from astrometry using such stars) embody the
* E-terms. If it is necessary to convert a formal mean
* place (for example a pulsar timing position) to one
* consistent with such a star catalogue, then the RA,Dec
* should be adjusted using this routine.
*
* Reference:
* Explanatory Supplement to the Astronomical Ephemeris,
* section 2D, page 48.
*
* Called: sla_ETRMS, sla_DCS2C, sla_DCC2S, sla_DRANRM, sla_DRANGE
*
* P.T.Wallace Starlink 18 March 1999
*
* Copyright (C) 1999 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RM,DM,EQ,RC,DC
DOUBLE PRECISION sla_DRANRM
DOUBLE PRECISION A(3),V(3)
INTEGER I
* E-terms vector
CALL sla_ETRMS(EQ,A)
* Spherical to Cartesian
CALL sla_DCS2C(RM,DM,V)
* Include the E-terms
DO I=1,3
V(I)=V(I)+A(I)
END DO
* Cartesian to spherical
CALL sla_DCC2S(V,RC,DC)
* Bring RA into conventional range
RC=sla_DRANRM(RC)
END

119
slalib/afin.f Normal file
View File

@ -0,0 +1,119 @@
SUBROUTINE sla_AFIN (STRING, IPTR, A, J)
*+
* - - - - -
* A F I N
* - - - - -
*
* Sexagesimal character string to angle (single precision)
*
* Given:
* STRING c*(*) string containing deg, arcmin, arcsec fields
* IPTR i pointer to start of decode (1st = 1)
*
* Returned:
* IPTR i advanced past the decoded angle
* A r angle in radians
* J i status: 0 = OK
* +1 = default, A unchanged
* -1 = bad degrees )
* -2 = bad arcminutes ) (note 3)
* -3 = bad arcseconds )
*
* Example:
*
* argument before after
*
* STRING '-57 17 44.806 12 34 56.7' unchanged
* IPTR 1 16 (points to 12...)
* A ? -1.00000
* J ? 0
*
* A further call to sla_AFIN, without adjustment of IPTR, will
* decode the second angle, 12deg 34min 56.7sec.
*
* Notes:
*
* 1) The first three "fields" in STRING are degrees, arcminutes,
* arcseconds, separated by spaces or commas. The degrees field
* may be signed, but not the others. The decoding is carried
* out by the DFLTIN routine and is free-format.
*
* 2) Successive fields may be absent, defaulting to zero. For
* zero status, the only combinations allowed are degrees alone,
* degrees and arcminutes, and all three fields present. If all
* three fields are omitted, a status of +1 is returned and A is
* unchanged. In all other cases A is changed.
*
* 3) Range checking:
*
* The degrees field is not range checked. However, it is
* expected to be integral unless the other two fields are
* absent.
*
* The arcminutes field is expected to be 0-59, and integral if
* the arcseconds field is present. If the arcseconds field
* is absent, the arcminutes is expected to be 0-59.9999...
*
* The arcseconds field is expected to be 0-59.9999...
*
* 4) Decoding continues even when a check has failed. Under these
* circumstances the field takes the supplied value, defaulting
* to zero, and the result A is computed and returned.
*
* 5) Further fields after the three expected ones are not treated
* as an error. The pointer IPTR is left in the correct state
* for further decoding with the present routine or with DFLTIN
* etc. See the example, above.
*
* 6) If STRING contains hours, minutes, seconds instead of degrees
* etc, or if the required units are turns (or days) instead of
* radians, the result A should be multiplied as follows:
*
* for to obtain multiply
* STRING A in A by
*
* d ' " radians 1 = 1.0
* d ' " turns 1/2pi = 0.1591549430918953358
* h m s radians 15 = 15.0
* h m s days 15/2pi = 2.3873241463784300365
*
* Called: sla_DAFIN
*
* P.T.Wallace Starlink 13 September 1990
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
CHARACTER*(*) STRING
INTEGER IPTR
REAL A
INTEGER J
DOUBLE PRECISION AD
* Call the double precision version
CALL sla_DAFIN(STRING,IPTR,AD,J)
IF (J.LE.0) A=REAL(AD)
END

75
slalib/airmas.f Normal file
View File

@ -0,0 +1,75 @@
DOUBLE PRECISION FUNCTION sla_AIRMAS (ZD)
*+
* - - - - - - -
* A I R M A S
* - - - - - - -
*
* Air mass at given zenith distance (double precision)
*
* Given:
* ZD d Observed zenith distance (radians)
*
* The result is an estimate of the air mass, in units of that
* at the zenith.
*
* Notes:
*
* 1) The "observed" zenith distance referred to above means "as
* affected by refraction".
*
* 2) Uses Hardie's (1962) polynomial fit to Bemporad's data for
* the relative air mass, X, in units of thickness at the zenith
* as tabulated by Schoenberg (1929). This is adequate for all
* normal needs as it is accurate to better than 0.1% up to X =
* 6.8 and better than 1% up to X = 10. Bemporad's tabulated
* values are unlikely to be trustworthy to such accuracy
* because of variations in density, pressure and other
* conditions in the atmosphere from those assumed in his work.
*
* 3) The sign of the ZD is ignored.
*
* 4) At zenith distances greater than about ZD = 87 degrees the
* air mass is held constant to avoid arithmetic overflows.
*
* References:
* Hardie, R.H., 1962, in "Astronomical Techniques"
* ed. W.A. Hiltner, University of Chicago Press, p180.
* Schoenberg, E., 1929, Hdb. d. Ap.,
* Berlin, Julius Springer, 2, 268.
*
* Original code by P.W.Hill, St Andrews
*
* P.T.Wallace Starlink 18 March 1999
*
* Copyright (C) 1999 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION ZD
DOUBLE PRECISION SECZM1
SECZM1 = 1D0/(COS(MIN(1.52D0,ABS(ZD))))-1D0
sla_AIRMAS = 1D0 + SECZM1*(0.9981833D0
: - SECZM1*(0.002875D0 + 0.0008083D0*SECZM1))
END

162
slalib/altaz.f Normal file
View File

@ -0,0 +1,162 @@
SUBROUTINE sla_ALTAZ (HA, DEC, PHI,
: AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD)
*+
* - - - - - -
* A L T A Z
* - - - - - -
*
* Positions, velocities and accelerations for an altazimuth
* telescope mount.
*
* (double precision)
*
* Given:
* HA d hour angle
* DEC d declination
* PHI d observatory latitude
*
* Returned:
* AZ d azimuth
* AZD d " velocity
* AZDD d " acceleration
* EL d elevation
* ELD d " velocity
* ELDD d " acceleration
* PA d parallactic angle
* PAD d " " velocity
* PADD d " " acceleration
*
* Notes:
*
* 1) Natural units are used throughout. HA, DEC, PHI, AZ, EL
* and ZD are in radians. The velocities and accelerations
* assume constant declination and constant rate of change of
* hour angle (as for tracking a star); the units of AZD, ELD
* and PAD are radians per radian of HA, while the units of AZDD,
* ELDD and PADD are radians per radian of HA squared. To
* convert into practical degree- and second-based units:
*
* angles * 360/2pi -> degrees
* velocities * (2pi/86400)*(360/2pi) -> degree/sec
* accelerations * ((2pi/86400)**2)*(360/2pi) -> degree/sec/sec
*
* Note that the seconds here are sidereal rather than SI. One
* sidereal second is about 0.99727 SI seconds.
*
* The velocity and acceleration factors assume the sidereal
* tracking case. Their respective numerical values are (exactly)
* 1/240 and (approximately) 1/3300236.9.
*
* 2) Azimuth is returned in the range 0-2pi; north is zero,
* and east is +pi/2. Elevation and parallactic angle are
* returned in the range +/-pi. Parallactic angle is +ve for
* a star west of the meridian and is the angle NP-star-zenith.
*
* 3) The latitude is geodetic as opposed to geocentric. The
* hour angle and declination are topocentric. Refraction and
* deficiencies in the telescope mounting are ignored. The
* purpose of the routine is to give the general form of the
* quantities. The details of a real telescope could profoundly
* change the results, especially close to the zenith.
*
* 4) No range checking of arguments is carried out.
*
* 5) In applications which involve many such calculations, rather
* than calling the present routine it will be more efficient to
* use inline code, having previously computed fixed terms such
* as sine and cosine of latitude, and (for tracking a star)
* sine and cosine of declination.
*
* This revision: 29 October 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION HA,DEC,PHI,AZ,AZD,AZDD,EL,ELD,ELDD,PA,PAD,PADD
DOUBLE PRECISION DPI,D2PI,TINY
PARAMETER (DPI=3.1415926535897932384626433832795D0,
: D2PI=6.283185307179586476925286766559D0,
: TINY=1D-30)
DOUBLE PRECISION SH,CH,SD,CD,SP,CP,CHCD,SDCP,X,Y,Z,RSQ,R,A,E,C,S,
: Q,QD,AD,ED,EDR,ADD,EDD,QDD
* Useful functions
SH=SIN(HA)
CH=COS(HA)
SD=SIN(DEC)
CD=COS(DEC)
SP=SIN(PHI)
CP=COS(PHI)
CHCD=CH*CD
SDCP=SD*CP
X=-CHCD*SP+SDCP
Y=-SH*CD
Z=CHCD*CP+SD*SP
RSQ=X*X+Y*Y
R=SQRT(RSQ)
* Azimuth and elevation
IF (RSQ.EQ.0D0) THEN
A=0D0
ELSE
A=ATAN2(Y,X)
END IF
IF (A.LT.0D0) A=A+D2PI
E=ATAN2(Z,R)
* Parallactic angle
C=CD*SP-CH*SDCP
S=SH*CP
IF (C*C+S*S.GT.0) THEN
Q=ATAN2(S,C)
ELSE
Q=DPI-HA
END IF
* Velocities and accelerations (clamped at zenith/nadir)
IF (RSQ.LT.TINY) THEN
RSQ=TINY
R=SQRT(RSQ)
END IF
QD=-X*CP/RSQ
AD=SP+Z*QD
ED=CP*Y/R
EDR=ED/R
ADD=EDR*(Z*SP+(2D0-RSQ)*QD)
EDD=-R*QD*AD
QDD=EDR*(SP+2D0*Z*QD)
* Results
AZ=A
AZD=AD
AZDD=ADD
EL=E
ELD=ED
ELDD=EDD
PA=Q
PAD=QD
PADD=QDD
END

88
slalib/amp.f Normal file
View File

@ -0,0 +1,88 @@
SUBROUTINE sla_AMP (RA, DA, DATE, EQ, RM, DM)
*+
* - - - -
* A M P
* - - - -
*
* Convert star RA,Dec from geocentric apparent to mean place
*
* The mean coordinate system is the post IAU 1976 system,
* loosely called FK5.
*
* Given:
* RA d apparent RA (radians)
* DA d apparent Dec (radians)
* DATE d TDB for apparent place (JD-2400000.5)
* EQ d equinox: Julian epoch of mean place
*
* Returned:
* RM d mean RA (radians)
* DM d mean Dec (radians)
*
* References:
* 1984 Astronomical Almanac, pp B39-B41.
* (also Lederle & Schwan, Astron. Astrophys. 134,
* 1-6, 1984)
*
* Notes:
*
* 1) The distinction between the required TDB and TT is always
* negligible. Moreover, for all but the most critical
* applications UTC is adequate.
*
* 2) Iterative techniques are used for the aberration and light
* deflection corrections so that the routines sla_AMP (or
* sla_AMPQK) and sla_MAP (or sla_MAPQK) are accurate inverses;
* even at the edge of the Sun's disc the discrepancy is only
* about 1 nanoarcsecond.
*
* 3) Where multiple apparent places are to be converted to mean
* places, for a fixed date and equinox, it is more efficient to
* use the sla_MAPPA routine to compute the required parameters
* once, followed by one call to sla_AMPQK per star.
*
* 4) The accuracy is sub-milliarcsecond, limited by the
* precession-nutation model (IAU 1976 precession, Shirai &
* Fukushima 2001 forced nutation and precession corrections).
*
* 5) The accuracy is further limited by the routine sla_EVP, called
* by sla_MAPPA, which computes the Earth position and velocity
* using the methods of Stumpff. The maximum error is about
* 0.3 mas.
*
* Called: sla_MAPPA, sla_AMPQK
*
* P.T.Wallace Starlink 17 September 2001
*
* Copyright (C) 2001 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RA,DA,DATE,EQ,RM,DM
DOUBLE PRECISION AMPRMS(21)
CALL sla_MAPPA(EQ,DATE,AMPRMS)
CALL sla_AMPQK(RA,DA,AMPRMS,RM,DM)
END

139
slalib/ampqk.f Normal file
View File

@ -0,0 +1,139 @@
SUBROUTINE sla_AMPQK (RA, DA, AMPRMS, RM, DM)
*+
* - - - - - -
* A M P Q K
* - - - - - -
*
* Convert star RA,Dec from geocentric apparent to mean place
*
* The mean coordinate system is the post IAU 1976 system,
* loosely called FK5.
*
* Use of this routine is appropriate when efficiency is important
* and where many star positions are all to be transformed for
* one epoch and equinox. The star-independent parameters can be
* obtained by calling the sla_MAPPA routine.
*
* Given:
* RA d apparent RA (radians)
* DA d apparent Dec (radians)
*
* AMPRMS d(21) star-independent mean-to-apparent parameters:
*
* (1) time interval for proper motion (Julian years)
* (2-4) barycentric position of the Earth (AU)
* (5-7) heliocentric direction of the Earth (unit vector)
* (8) (grav rad Sun)*2/(Sun-Earth distance)
* (9-11) ABV: barycentric Earth velocity in units of c
* (12) sqrt(1-v**2) where v=modulus(ABV)
* (13-21) precession/nutation (3,3) matrix
*
* Returned:
* RM d mean RA (radians)
* DM d mean Dec (radians)
*
* References:
* 1984 Astronomical Almanac, pp B39-B41.
* (also Lederle & Schwan, Astron. Astrophys. 134,
* 1-6, 1984)
*
* Note:
*
* Iterative techniques are used for the aberration and
* light deflection corrections so that the routines
* sla_AMP (or sla_AMPQK) and sla_MAP (or sla_MAPQK) are
* accurate inverses; even at the edge of the Sun's disc
* the discrepancy is only about 1 nanoarcsecond.
*
* Called: sla_DCS2C, sla_DIMXV, sla_DVDV, sla_DVN, sla_DCC2S,
* sla_DRANRM
*
* P.T.Wallace Starlink 7 May 2000
*
* Copyright (C) 2000 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RA,DA,AMPRMS(21),RM,DM
INTEGER I,J
DOUBLE PRECISION GR2E,AB1,EHN(3),ABV(3),P3(3),P2(3),
: AB1P1,P1DV,P1DVP1,P1(3),W,PDE,PDEP1,P(3)
DOUBLE PRECISION sla_DVDV,sla_DRANRM
* Unpack scalar and vector parameters
GR2E = AMPRMS(8)
AB1 = AMPRMS(12)
DO I=1,3
EHN(I) = AMPRMS(I+4)
ABV(I) = AMPRMS(I+8)
END DO
* Apparent RA,Dec to Cartesian
CALL sla_DCS2C(RA,DA,P3)
* Precession and nutation
CALL sla_DIMXV(AMPRMS(13),P3,P2)
* Aberration
AB1P1 = AB1+1D0
DO I=1,3
P1(I) = P2(I)
END DO
DO J=1,2
P1DV = sla_DVDV(P1,ABV)
P1DVP1 = 1D0+P1DV
W = 1D0+P1DV/AB1P1
DO I=1,3
P1(I) = (P1DVP1*P2(I)-W*ABV(I))/AB1
END DO
CALL sla_DVN(P1,P3,W)
DO I=1,3
P1(I) = P3(I)
END DO
END DO
* Light deflection
DO I=1,3
P(I) = P1(I)
END DO
DO J=1,5
PDE = sla_DVDV(P,EHN)
PDEP1 = 1D0+PDE
W = PDEP1-GR2E*PDE
DO I=1,3
P(I) = (PDEP1*P1(I)-GR2E*EHN(I))/W
END DO
CALL sla_DVN(P,P2,W)
DO I=1,3
P(I) = P2(I)
END DO
END DO
* Mean RA,Dec
CALL sla_DCC2S(P,RM,DM)
RM = sla_DRANRM(RM)
END

191
slalib/aop.f Normal file
View File

@ -0,0 +1,191 @@
SUBROUTINE sla_AOP ( RAP, DAP, DATE, DUT, ELONGM, PHIM, HM,
: XP, YP, TDK, PMB, RH, WL, TLR,
: AOB, ZOB, HOB, DOB, ROB )
*+
* - - - -
* A O P
* - - - -
*
* Apparent to observed place, for sources distant from the solar
* system.
*
* Given:
* RAP d geocentric apparent right ascension
* DAP d geocentric apparent declination
* DATE d UTC date/time (Modified Julian Date, JD-2400000.5)
* DUT d delta UT: UT1-UTC (UTC seconds)
* ELONGM d mean longitude of the observer (radians, east +ve)
* PHIM d mean geodetic latitude of the observer (radians)
* HM d observer's height above sea level (metres)
* XP d polar motion x-coordinate (radians)
* YP d polar motion y-coordinate (radians)
* TDK d local ambient temperature (K; std=273.15D0)
* PMB d local atmospheric pressure (mb; std=1013.25D0)
* RH d local relative humidity (in the range 0D0-1D0)
* WL d effective wavelength (micron, e.g. 0.55D0)
* TLR d tropospheric lapse rate (K/metre, e.g. 0.0065D0)
*
* Returned:
* AOB d observed azimuth (radians: N=0,E=90)
* ZOB d observed zenith distance (radians)
* HOB d observed Hour Angle (radians)
* DOB d observed Declination (radians)
* ROB d observed Right Ascension (radians)
*
* Notes:
*
* 1) This routine returns zenith distance rather than elevation
* in order to reflect the fact that no allowance is made for
* depression of the horizon.
*
* 2) The accuracy of the result is limited by the corrections for
* refraction. Providing the meteorological parameters are
* known accurately and there are no gross local effects, the
* predicted apparent RA,Dec should be within about 0.1 arcsec
* for a zenith distance of less than 70 degrees. Even at a
* topocentric zenith distance of 90 degrees, the accuracy in
* elevation should be better than 1 arcmin; useful results
* are available for a further 3 degrees, beyond which the
* sla_REFRO routine returns a fixed value of the refraction.
* The complementary routines sla_AOP (or sla_AOPQK) and sla_OAP
* (or sla_OAPQK) are self-consistent to better than 1 micro-
* arcsecond all over the celestial sphere.
*
* 3) It is advisable to take great care with units, as even
* unlikely values of the input parameters are accepted and
* processed in accordance with the models used.
*
* 4) "Apparent" place means the geocentric apparent right ascension
* and declination, which is obtained from a catalogue mean place
* by allowing for space motion, parallax, precession, nutation,
* annual aberration, and the Sun's gravitational lens effect. For
* star positions in the FK5 system (i.e. J2000), these effects can
* be applied by means of the sla_MAP etc routines. Starting from
* other mean place systems, additional transformations will be
* needed; for example, FK4 (i.e. B1950) mean places would first
* have to be converted to FK5, which can be done with the
* sla_FK425 etc routines.
*
* 5) "Observed" Az,El means the position that would be seen by a
* perfect theodolite located at the observer. This is obtained
* from the geocentric apparent RA,Dec by allowing for Earth
* orientation and diurnal aberration, rotating from equator
* to horizon coordinates, and then adjusting for refraction.
* The HA,Dec is obtained by rotating back into equatorial
* coordinates, using the geodetic latitude corrected for polar
* motion, and is the position that would be seen by a perfect
* equatorial located at the observer and with its polar axis
* aligned to the Earth's axis of rotation (n.b. not to the
* refracted pole). Finally, the RA is obtained by subtracting
* the HA from the local apparent ST.
*
* 6) To predict the required setting of a real telescope, the
* observed place produced by this routine would have to be
* adjusted for the tilt of the azimuth or polar axis of the
* mounting (with appropriate corrections for mount flexures),
* for non-perpendicularity between the mounting axes, for the
* position of the rotator axis and the pointing axis relative
* to it, for tube flexure, for gear and encoder errors, and
* finally for encoder zero points. Some telescopes would, of
* course, exhibit other properties which would need to be
* accounted for at the appropriate point in the sequence.
*
* 7) This routine takes time to execute, due mainly to the
* rigorous integration used to evaluate the refraction.
* For processing multiple stars for one location and time,
* call sla_AOPPA once followed by one call per star to sla_AOPQK.
* Where a range of times within a limited period of a few hours
* is involved, and the highest precision is not required, call
* sla_AOPPA once, followed by a call to sla_AOPPAT each time the
* time changes, followed by one call per star to sla_AOPQK.
*
* 8) The DATE argument is UTC expressed as an MJD. This is,
* strictly speaking, wrong, because of leap seconds. However,
* as long as the delta UT and the UTC are consistent there
* are no difficulties, except during a leap second. In this
* case, the start of the 61st second of the final minute should
* begin a new MJD day and the old pre-leap delta UT should
* continue to be used. As the 61st second completes, the MJD
* should revert to the start of the day as, simultaneously,
* the delta UTC changes by one second to its post-leap new value.
*
* 9) The delta UT (UT1-UTC) is tabulated in IERS circulars and
* elsewhere. It increases by exactly one second at the end of
* each UTC leap second, introduced in order to keep delta UT
* within +/- 0.9 seconds.
*
* 10) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION.
* The longitude required by the present routine is east-positive,
* in accordance with geographical convention (and right-handed).
* In particular, note that the longitudes returned by the
* sla_OBS routine are west-positive, following astronomical
* usage, and must be reversed in sign before use in the present
* routine.
*
* 11) The polar coordinates XP,YP can be obtained from IERS
* circulars and equivalent publications. The maximum amplitude
* is about 0.3 arcseconds. If XP,YP values are unavailable,
* use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac
* for a definition of the two angles.
*
* 12) The height above sea level of the observing station, HM,
* can be obtained from the Astronomical Almanac (Section J
* in the 1988 edition), or via the routine sla_OBS. If P,
* the pressure in millibars, is available, an adequate
* estimate of HM can be obtained from the expression
*
* HM ~ -29.3D0*TSL*LOG(P/1013.25D0).
*
* where TSL is the approximate sea-level air temperature in K
* (see Astrophysical Quantities, C.W.Allen, 3rd edition,
* section 52). Similarly, if the pressure P is not known,
* it can be estimated from the height of the observing
* station, HM, as follows:
*
* P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)).
*
* Note, however, that the refraction is nearly proportional to the
* pressure and that an accurate P value is important for precise
* work.
*
* 13) The azimuths etc produced by the present routine are with
* respect to the celestial pole. Corrections to the terrestrial
* pole can be computed using sla_POLMO.
*
* Called: sla_AOPPA, sla_AOPQK
*
* Last revision: 2 December 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RAP,DAP,DATE,DUT,ELONGM,PHIM,HM,
: XP,YP,TDK,PMB,RH,WL,TLR,AOB,ZOB,HOB,DOB,ROB
DOUBLE PRECISION AOPRMS(14)
CALL sla_AOPPA(DATE,DUT,ELONGM,PHIM,HM,XP,YP,TDK,PMB,RH,WL,TLR,
: AOPRMS)
CALL sla_AOPQK(RAP,DAP,AOPRMS,AOB,ZOB,HOB,DOB,ROB)
END

193
slalib/aoppa.f Normal file
View File

@ -0,0 +1,193 @@
SUBROUTINE sla_AOPPA ( DATE, DUT, ELONGM, PHIM, HM,
: XP, YP, TDK, PMB, RH, WL, TLR, AOPRMS )
*+
* - - - - - -
* A O P P A
* - - - - - -
*
* Precompute apparent to observed place parameters required by
* sla_AOPQK and sla_OAPQK.
*
* Given:
* DATE d UTC date/time (modified Julian Date, JD-2400000.5)
* DUT d delta UT: UT1-UTC (UTC seconds)
* ELONGM d mean longitude of the observer (radians, east +ve)
* PHIM d mean geodetic latitude of the observer (radians)
* HM d observer's height above sea level (metres)
* XP d polar motion x-coordinate (radians)
* YP d polar motion y-coordinate (radians)
* TDK d local ambient temperature (K; std=273.15D0)
* PMB d local atmospheric pressure (mb; std=1013.25D0)
* RH d local relative humidity (in the range 0D0-1D0)
* WL d effective wavelength (micron, e.g. 0.55D0)
* TLR d tropospheric lapse rate (K/metre, e.g. 0.0065D0)
*
* Returned:
* AOPRMS d(14) star-independent apparent-to-observed parameters:
*
* (1) geodetic latitude (radians)
* (2,3) sine and cosine of geodetic latitude
* (4) magnitude of diurnal aberration vector
* (5) height (HM)
* (6) ambient temperature (TDK)
* (7) pressure (PMB)
* (8) relative humidity (RH)
* (9) wavelength (WL)
* (10) lapse rate (TLR)
* (11,12) refraction constants A and B (radians)
* (13) longitude + eqn of equinoxes + sidereal DUT (radians)
* (14) local apparent sidereal time (radians)
*
* Notes:
*
* 1) It is advisable to take great care with units, as even
* unlikely values of the input parameters are accepted and
* processed in accordance with the models used.
*
* 2) The DATE argument is UTC expressed as an MJD. This is,
* strictly speaking, improper, because of leap seconds. However,
* as long as the delta UT and the UTC are consistent there
* are no difficulties, except during a leap second. In this
* case, the start of the 61st second of the final minute should
* begin a new MJD day and the old pre-leap delta UT should
* continue to be used. As the 61st second completes, the MJD
* should revert to the start of the day as, simultaneously,
* the delta UTC changes by one second to its post-leap new value.
*
* 3) The delta UT (UT1-UTC) is tabulated in IERS circulars and
* elsewhere. It increases by exactly one second at the end of
* each UTC leap second, introduced in order to keep delta UT
* within +/- 0.9 seconds.
*
* 4) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION.
* The longitude required by the present routine is east-positive,
* in accordance with geographical convention (and right-handed).
* In particular, note that the longitudes returned by the
* sla_OBS routine are west-positive, following astronomical
* usage, and must be reversed in sign before use in the present
* routine.
*
* 5) The polar coordinates XP,YP can be obtained from IERS
* circulars and equivalent publications. The maximum amplitude
* is about 0.3 arcseconds. If XP,YP values are unavailable,
* use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac
* for a definition of the two angles.
*
* 6) The height above sea level of the observing station, HM,
* can be obtained from the Astronomical Almanac (Section J
* in the 1988 edition), or via the routine sla_OBS. If P,
* the pressure in millibars, is available, an adequate
* estimate of HM can be obtained from the expression
*
* HM ~ -29.3D0*TSL*LOG(P/1013.25D0).
*
* where TSL is the approximate sea-level air temperature in K
* (see Astrophysical Quantities, C.W.Allen, 3rd edition,
* section 52). Similarly, if the pressure P is not known,
* it can be estimated from the height of the observing
* station, HM, as follows:
*
* P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)).
*
* Note, however, that the refraction is nearly proportional to the
* pressure and that an accurate P value is important for precise
* work.
*
* 7) Repeated, computationally-expensive, calls to sla_AOPPA for
* times that are very close together can be avoided by calling
* sla_AOPPA just once and then using sla_AOPPAT for the subsequent
* times. Fresh calls to sla_AOPPA will be needed only when
* changes in the precession have grown to unacceptable levels or
* when anything affecting the refraction has changed.
*
* Called: sla_GEOC, sla_REFCO, sla_EQEQX, sla_AOPPAT
*
* Last revision: 2 December 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DATE,DUT,ELONGM,PHIM,HM,XP,YP,TDK,PMB,
: RH,WL,TLR,AOPRMS(14)
DOUBLE PRECISION sla_EQEQX
* 2Pi
DOUBLE PRECISION D2PI
PARAMETER (D2PI=6.283185307179586476925287D0)
* Seconds of time to radians
DOUBLE PRECISION S2R
PARAMETER (S2R=7.272205216643039903848712D-5)
* Speed of light (AU per day)
DOUBLE PRECISION C
PARAMETER (C=173.14463331D0)
* Ratio between solar and sidereal time
DOUBLE PRECISION SOLSID
PARAMETER (SOLSID=1.00273790935D0)
DOUBLE PRECISION CPHIM,XT,YT,ZT,XC,YC,ZC,ELONG,PHI,UAU,VAU
* Observer's location corrected for polar motion
CPHIM = COS(PHIM)
XT = COS(ELONGM)*CPHIM
YT = SIN(ELONGM)*CPHIM
ZT = SIN(PHIM)
XC = XT-XP*ZT
YC = YT+YP*ZT
ZC = XP*XT-YP*YT+ZT
IF (XC.EQ.0D0.AND.YC.EQ.0D0) THEN
ELONG = 0D0
ELSE
ELONG = ATAN2(YC,XC)
END IF
PHI = ATAN2(ZC,SQRT(XC*XC+YC*YC))
AOPRMS(1) = PHI
AOPRMS(2) = SIN(PHI)
AOPRMS(3) = COS(PHI)
* Magnitude of the diurnal aberration vector
CALL sla_GEOC(PHI,HM,UAU,VAU)
AOPRMS(4) = D2PI*UAU*SOLSID/C
* Copy the refraction parameters and compute the A & B constants
AOPRMS(5) = HM
AOPRMS(6) = TDK
AOPRMS(7) = PMB
AOPRMS(8) = RH
AOPRMS(9) = WL
AOPRMS(10) = TLR
CALL sla_REFCO(HM,TDK,PMB,RH,WL,PHI,TLR,1D-10,
: AOPRMS(11),AOPRMS(12))
* Longitude + equation of the equinoxes + sidereal equivalent of DUT
* (ignoring change in equation of the equinoxes between UTC and TDB)
AOPRMS(13) = ELONG+sla_EQEQX(DATE)+DUT*SOLSID*S2R
* Sidereal time
CALL sla_AOPPAT(DATE,AOPRMS)
END

62
slalib/aoppat.f Normal file
View File

@ -0,0 +1,62 @@
SUBROUTINE sla_AOPPAT (DATE, AOPRMS)
*+
* - - - - - - -
* A O P P A T
* - - - - - - -
*
* Recompute the sidereal time in the apparent to observed place
* star-independent parameter block.
*
* Given:
* DATE d UTC date/time (modified Julian Date, JD-2400000.5)
* (see AOPPA source for comments on leap seconds)
*
* AOPRMS d(14) star-independent apparent-to-observed parameters
*
* (1-12) not required
* (13) longitude + eqn of equinoxes + sidereal DUT
* (14) not required
*
* Returned:
* AOPRMS d(14) star-independent apparent-to-observed parameters:
*
* (1-13) not changed
* (14) local apparent sidereal time (radians)
*
* For more information, see sla_AOPPA.
*
* Called: sla_GMST
*
* P.T.Wallace Starlink 1 July 1993
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DATE,AOPRMS(14)
DOUBLE PRECISION sla_GMST
AOPRMS(14) = sla_GMST(DATE)+AOPRMS(13)
END

259
slalib/aopqk.f Normal file
View File

@ -0,0 +1,259 @@
SUBROUTINE sla_AOPQK (RAP, DAP, AOPRMS, AOB, ZOB, HOB, DOB, ROB)
*+
* - - - - - -
* A O P Q K
* - - - - - -
*
* Quick apparent to observed place (but see note 8, below, for
* remarks about speed).
*
* Given:
* RAP d geocentric apparent right ascension
* DAP d geocentric apparent declination
* AOPRMS d(14) star-independent apparent-to-observed parameters:
*
* (1) geodetic latitude (radians)
* (2,3) sine and cosine of geodetic latitude
* (4) magnitude of diurnal aberration vector
* (5) height (HM)
* (6) ambient temperature (T)
* (7) pressure (P)
* (8) relative humidity (RH)
* (9) wavelength (WL)
* (10) lapse rate (TLR)
* (11,12) refraction constants A and B (radians)
* (13) longitude + eqn of equinoxes + sidereal DUT (radians)
* (14) local apparent sidereal time (radians)
*
* Returned:
* AOB d observed azimuth (radians: N=0,E=90)
* ZOB d observed zenith distance (radians)
* HOB d observed Hour Angle (radians)
* DOB d observed Declination (radians)
* ROB d observed Right Ascension (radians)
*
* Notes:
*
* 1) This routine returns zenith distance rather than elevation
* in order to reflect the fact that no allowance is made for
* depression of the horizon.
*
* 2) The accuracy of the result is limited by the corrections for
* refraction. Providing the meteorological parameters are
* known accurately and there are no gross local effects, the
* observed RA,Dec predicted by this routine should be within
* about 0.1 arcsec for a zenith distance of less than 70 degrees.
* Even at a topocentric zenith distance of 90 degrees, the
* accuracy in elevation should be better than 1 arcmin; useful
* results are available for a further 3 degrees, beyond which
* the sla_REFRO routine returns a fixed value of the refraction.
* The complementary routines sla_AOP (or sla_AOPQK) and sla_OaAP
* (or sla_OAPQK) are self-consistent to better than 1 micro-
* arcsecond all over the celestial sphere.
*
* 3) It is advisable to take great care with units, as even
* unlikely values of the input parameters are accepted and
* processed in accordance with the models used.
*
* 4) "Apparent" place means the geocentric apparent right ascension
* and declination, which is obtained from a catalogue mean place
* by allowing for space motion, parallax, precession, nutation,
* annual aberration, and the Sun's gravitational lens effect. For
* star positions in the FK5 system (i.e. J2000), these effects can
* be applied by means of the sla_MAP etc routines. Starting from
* other mean place systems, additional transformations will be
* needed; for example, FK4 (i.e. B1950) mean places would first
* have to be converted to FK5, which can be done with the
* sla_FK425 etc routines.
*
* 5) "Observed" Az,El means the position that would be seen by a
* perfect theodolite located at the observer. This is obtained
* from the geocentric apparent RA,Dec by allowing for Earth
* orientation and diurnal aberration, rotating from equator
* to horizon coordinates, and then adjusting for refraction.
* The HA,Dec is obtained by rotating back into equatorial
* coordinates, using the geodetic latitude corrected for polar
* motion, and is the position that would be seen by a perfect
* equatorial located at the observer and with its polar axis
* aligned to the Earth's axis of rotation (n.b. not to the
* refracted pole). Finally, the RA is obtained by subtracting
* the HA from the local apparent ST.
*
* 6) To predict the required setting of a real telescope, the
* observed place produced by this routine would have to be
* adjusted for the tilt of the azimuth or polar axis of the
* mounting (with appropriate corrections for mount flexures),
* for non-perpendicularity between the mounting axes, for the
* position of the rotator axis and the pointing axis relative
* to it, for tube flexure, for gear and encoder errors, and
* finally for encoder zero points. Some telescopes would, of
* course, exhibit other properties which would need to be
* accounted for at the appropriate point in the sequence.
*
* 7) The star-independent apparent-to-observed-place parameters
* in AOPRMS may be computed by means of the sla_AOPPA routine.
* If nothing has changed significantly except the time, the
* sla_AOPPAT routine may be used to perform the requisite
* partial recomputation of AOPRMS.
*
* 8) At zenith distances beyond about 76 degrees, the need for
* special care with the corrections for refraction causes a
* marked increase in execution time. Moreover, the effect
* gets worse with increasing zenith distance. Adroit
* programming in the calling application may allow the
* problem to be reduced. Prepare an alternative AOPRMS array,
* computed for zero air-pressure; this will disable the
* refraction corrections and cause rapid execution. Using
* this AOPRMS array, a preliminary call to the present routine
* will, depending on the application, produce a rough position
* which may be enough to establish whether the full, slow
* calculation (using the real AOPRMS array) is worthwhile.
* For example, there would be no need for the full calculation
* if the preliminary call had already established that the
* source was well below the elevation limits for a particular
* telescope.
*
* 9) The azimuths etc produced by the present routine are with
* respect to the celestial pole. Corrections to the terrestrial
* pole can be computed using sla_POLMO.
*
* Called: sla_DCS2C, sla_REFZ, sla_REFRO, sla_DCC2S, sla_DRANRM
*
* P.T.Wallace Starlink 24 October 2003
*
* Copyright (C) 2003 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RAP,DAP,AOPRMS(14),AOB,ZOB,HOB,DOB,ROB
* Breakpoint for fast/slow refraction algorithm:
* ZD greater than arctan(4), (see sla_REFCO routine)
* or vector Z less than cosine(arctan(Z)) = 1/sqrt(17)
DOUBLE PRECISION ZBREAK
PARAMETER (ZBREAK=0.242535625D0)
INTEGER I
DOUBLE PRECISION SPHI,CPHI,ST,V(3),XHD,YHD,ZHD,DIURAB,F,
: XHDT,YHDT,ZHDT,XAET,YAET,ZAET,AZOBS,
: ZDT,REFA,REFB,ZDOBS,DZD,DREF,CE,
: XAEO,YAEO,ZAEO,HMOBS,DCOBS,RAOBS
DOUBLE PRECISION sla_DRANRM
* Sin, cos of latitude
SPHI = AOPRMS(2)
CPHI = AOPRMS(3)
* Local apparent sidereal time
ST = AOPRMS(14)
* Apparent RA,Dec to Cartesian -HA,Dec
CALL sla_DCS2C(RAP-ST,DAP,V)
XHD = V(1)
YHD = V(2)
ZHD = V(3)
* Diurnal aberration
DIURAB = AOPRMS(4)
F = (1D0-DIURAB*YHD)
XHDT = F*XHD
YHDT = F*(YHD+DIURAB)
ZHDT = F*ZHD
* Cartesian -HA,Dec to Cartesian Az,El (S=0,E=90)
XAET = SPHI*XHDT-CPHI*ZHDT
YAET = YHDT
ZAET = CPHI*XHDT+SPHI*ZHDT
* Azimuth (N=0,E=90)
IF (XAET.EQ.0D0.AND.YAET.EQ.0D0) THEN
AZOBS = 0D0
ELSE
AZOBS = ATAN2(YAET,-XAET)
END IF
* Topocentric zenith distance
ZDT = ATAN2(SQRT(XAET*XAET+YAET*YAET),ZAET)
*
* Refraction
* ----------
* Fast algorithm using two constant model
REFA = AOPRMS(11)
REFB = AOPRMS(12)
CALL sla_REFZ(ZDT,REFA,REFB,ZDOBS)
* Large zenith distance?
IF (COS(ZDOBS).LT.ZBREAK) THEN
* Yes: use rigorous algorithm
* Initialize loop (maximum of 10 iterations)
I = 1
DZD = 1D1
DO WHILE (ABS(DZD).GT.1D-10.AND.I.LE.10)
* Compute refraction using current estimate of observed ZD
CALL sla_REFRO(ZDOBS,AOPRMS(5),AOPRMS(6),AOPRMS(7),
: AOPRMS(8),AOPRMS(9),AOPRMS(1),
: AOPRMS(10),1D-8,DREF)
* Remaining discrepancy
DZD = ZDOBS+DREF-ZDT
* Update the estimate
ZDOBS = ZDOBS-DZD
* Increment the iteration counter
I = I+1
END DO
END IF
* To Cartesian Az/ZD
CE = SIN(ZDOBS)
XAEO = -COS(AZOBS)*CE
YAEO = SIN(AZOBS)*CE
ZAEO = COS(ZDOBS)
* Cartesian Az/ZD to Cartesian -HA,Dec
V(1) = SPHI*XAEO+CPHI*ZAEO
V(2) = YAEO
V(3) = -CPHI*XAEO+SPHI*ZAEO
* To spherical -HA,Dec
CALL sla_DCC2S(V,HMOBS,DCOBS)
* Right Ascension
RAOBS = sla_DRANRM(ST+HMOBS)
* Return the results
AOB = AZOBS
ZOB = ZDOBS
HOB = -HMOBS
DOB = DCOBS
ROB = RAOBS
END

140
slalib/atmdsp.f Normal file
View File

@ -0,0 +1,140 @@
SUBROUTINE sla_ATMDSP (TDK, PMB, RH, WL1, A1, B1, WL2, A2, B2)
*+
* - - - - - - -
* A T M D S P
* - - - - - - -
*
* Apply atmospheric-dispersion adjustments to refraction coefficients.
*
* Given:
* TDK d ambient temperature, K
* PMB d ambient pressure, millibars
* RH d ambient relative humidity, 0-1
* WL1 d reference wavelength, micrometre (0.4D0 recommended)
* A1 d refraction coefficient A for wavelength WL1 (radians)
* B1 d refraction coefficient B for wavelength WL1 (radians)
* WL2 d wavelength for which adjusted A,B required
*
* Returned:
* A2 d refraction coefficient A for wavelength WL2 (radians)
* B2 d refraction coefficient B for wavelength WL2 (radians)
*
* Notes:
*
* 1 To use this routine, first call sla_REFCO specifying WL1 as the
* wavelength. This yields refraction coefficients A1,B1, correct
* for that wavelength. Subsequently, calls to sla_ATMDSP specifying
* different wavelengths will produce new, slightly adjusted
* refraction coefficients which apply to the specified wavelength.
*
* 2 Most of the atmospheric dispersion happens between 0.7 micrometre
* and the UV atmospheric cutoff, and the effect increases strongly
* towards the UV end. For this reason a blue reference wavelength
* is recommended, for example 0.4 micrometres.
*
* 3 The accuracy, for this set of conditions:
*
* height above sea level 2000 m
* latitude 29 deg
* pressure 793 mb
* temperature 17 degC
* humidity 50%
* lapse rate 0.0065 degC/m
* reference wavelength 0.4 micrometre
* star elevation 15 deg
*
* is about 2.5 mas RMS between 0.3 and 1.0 micrometres, and stays
* within 4 mas for the whole range longward of 0.3 micrometres
* (compared with a total dispersion from 0.3 to 20.0 micrometres
* of about 11 arcsec). These errors are typical for ordinary
* conditions and the given elevation; in extreme conditions values
* a few times this size may occur, while at higher elevations the
* errors become much smaller.
*
* 4 If either wavelength exceeds 100 micrometres, the radio case
* is assumed and the returned refraction coefficients are the
* same as the given ones. Note that radio refraction coefficients
* cannot be turned into optical values using this routine, nor
* vice versa.
*
* 5 The algorithm consists of calculation of the refractivity of the
* air at the observer for the two wavelengths, using the methods
* of the sla_REFRO routine, and then scaling of the two refraction
* coefficients according to classical refraction theory. This
* amounts to scaling the A coefficient in proportion to (n-1) and
* the B coefficient almost in the same ratio (see R.M.Green,
* "Spherical Astronomy", Cambridge University Press, 1985).
*
* Last revision 2 December 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION TDK,PMB,RH,WL1,A1,B1,WL2,A2,B2
DOUBLE PRECISION F,TDKOK,PMBOK,RHOK,
: PSAT,PWO,W1,WLOK,WLSQ,W2,DN1,DN2
* Check for radio wavelengths
IF (WL1.GT.100D0.OR.WL2.GT.100D0) THEN
* Radio: no dispersion
A2 = A1
B2 = B1
ELSE
* Optical: keep arguments within safe bounds
TDKOK = MIN(MAX(TDK,100D0),500D0)
PMBOK = MIN(MAX(PMB,0D0),10000D0)
RHOK = MIN(MAX(RH,0D0),1D0)
* Atmosphere parameters at the observer
PSAT = 10D0**(-8.7115D0+0.03477D0*TDKOK)
PWO = RHOK*PSAT
W1 = 11.2684D-6*PWO
* Refractivity at the observer for first wavelength
WLOK = MAX(WL1,0.1D0)
WLSQ = WLOK*WLOK
W2 = 77.5317D-6+(0.43909D-6+0.00367D-6/WLSQ)/WLSQ
DN1 = (W2*PMBOK-W1)/TDKOK
* Refractivity at the observer for second wavelength
WLOK = MAX(WL2,0.1D0)
WLSQ = WLOK*WLOK
W2 = 77.5317D-6+(0.43909D-6+0.00367D-6/WLSQ)/WLSQ
DN2 = (W2*PMBOK-W1)/TDKOK
* Scale the refraction coefficients (see Green 4.31, p93)
IF (DN1.NE.0D0) THEN
F = DN2/DN1
A2 = A1*F
B2 = B1*F
IF (DN1.NE.A1) B2=B2*(1D0+DN1*(DN1-DN2)/(2D0*(DN1-A1)))
ELSE
A2 = A1
B2 = B1
END IF
END IF
END

57
slalib/atms.f Normal file
View File

@ -0,0 +1,57 @@
SUBROUTINE sla__ATMS (RT, TT, DNT, GAMAL, R, DN, RDNDR)
*+
* - - - - -
* A T M S
* - - - - -
*
* Internal routine used by REFRO
*
* Refractive index and derivative with respect to height for the
* stratosphere.
*
* Given:
* RT d height of tropopause from centre of the Earth (metre)
* TT d temperature at the tropopause (K)
* DNT d refractive index at the tropopause
* GAMAL d constant of the atmospheric model = G*MD/R
* R d current distance from the centre of the Earth (metre)
*
* Returned:
* DN d refractive index at R
* RDNDR d R * rate the refractive index is changing at R
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RT,TT,DNT,GAMAL,R,DN,RDNDR
DOUBLE PRECISION B,W
B = GAMAL/TT
W = (DNT-1D0)*EXP(-B*(R-RT))
DN = 1D0+W
RDNDR = -R*B*W
END

71
slalib/atmt.f Normal file
View File

@ -0,0 +1,71 @@
SUBROUTINE sla__ATMT (R0, T0, ALPHA, GAMM2, DELM2,
: C1, C2, C3, C4, C5, C6, R, T, DN, RDNDR)
*+
* - - - - -
* A T M T
* - - - - -
*
* Internal routine used by REFRO
*
* Refractive index and derivative with respect to height for the
* troposphere.
*
* Given:
* R0 d height of observer from centre of the Earth (metre)
* T0 d temperature at the observer (K)
* ALPHA d alpha )
* GAMM2 d gamma minus 2 ) see HMNAO paper
* DELM2 d delta minus 2 )
* C1 d useful term )
* C2 d useful term )
* C3 d useful term ) see source
* C4 d useful term ) of sla_REFRO
* C5 d useful term )
* C6 d useful term )
* R d current distance from the centre of the Earth (metre)
*
* Returned:
* T d temperature at R (K)
* DN d refractive index at R
* RDNDR d R * rate the refractive index is changing at R
*
* Note that in the optical case C5 and C6 are zero.
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION R0,T0,ALPHA,GAMM2,DELM2,C1,C2,C3,C4,C5,C6,
: R,T,DN,RDNDR
DOUBLE PRECISION TT0,TT0GM2,TT0DM2
T = MAX(MIN(T0-ALPHA*(R-R0),320D0),100D0)
TT0 = T/T0
TT0GM2 = TT0**GAMM2
TT0DM2 = TT0**DELM2
DN = 1D0+(C1*TT0GM2-(C2-C5/T)*TT0DM2)*TT0
RDNDR = R*(-C3*TT0GM2+(C4-C6/TT0)*TT0DM2)
END

84
slalib/av2m.f Normal file
View File

@ -0,0 +1,84 @@
SUBROUTINE sla_AV2M (AXVEC, RMAT)
*+
* - - - - -
* A V 2 M
* - - - - -
*
* Form the rotation matrix corresponding to a given axial vector.
*
* (single precision)
*
* A rotation matrix describes a rotation about some arbitrary axis,
* called the Euler axis. The "axial vector" supplied to this routine
* has the same direction as the Euler axis, and its magnitude is the
* amount of rotation in radians.
*
* Given:
* AXVEC r(3) axial vector (radians)
*
* Returned:
* RMAT r(3,3) rotation matrix
*
* If AXVEC is null, the unit matrix is returned.
*
* The reference frame rotates clockwise as seen looking along
* the axial vector from the origin.
*
* Last revision: 26 November 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL AXVEC(3),RMAT(3,3)
REAL X,Y,Z,PHI,S,C,W
* Rotation angle - magnitude of axial vector - and functions
X = AXVEC(1)
Y = AXVEC(2)
Z = AXVEC(3)
PHI = SQRT(X*X+Y*Y+Z*Z)
S = SIN(PHI)
C = COS(PHI)
W = 1.0-C
* Euler axis - direction of axial vector (perhaps null)
IF (PHI.NE.0.0) THEN
X = X/PHI
Y = Y/PHI
Z = Z/PHI
END IF
* Compute the rotation matrix
RMAT(1,1) = X*X*W+C
RMAT(1,2) = X*Y*W+Z*S
RMAT(1,3) = X*Z*W-Y*S
RMAT(2,1) = X*Y*W-Z*S
RMAT(2,2) = Y*Y*W+C
RMAT(2,3) = Y*Z*W+X*S
RMAT(3,1) = X*Z*W+Y*S
RMAT(3,2) = Y*Z*W-X*S
RMAT(3,3) = Z*Z*W+C
END

59
slalib/bear.f Normal file
View File

@ -0,0 +1,59 @@
REAL FUNCTION sla_BEAR (A1, B1, A2, B2)
*+
* - - - - -
* B E A R
* - - - - -
*
* Bearing (position angle) of one point on a sphere relative to another
* (single precision)
*
* Given:
* A1,B1 r spherical coordinates of one point
* A2,B2 r spherical coordinates of the other point
*
* (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.)
*
* The result is the bearing (position angle), in radians, of point
* A2,B2 as seen from point A1,B1. It is in the range +/- pi. If
* A2,B2 is due east of A1,B1 the bearing is +pi/2. Zero is returned
* if the two points are coincident.
*
* P.T.Wallace Starlink 23 March 1991
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL A1,B1,A2,B2
REAL DA,X,Y
DA=A2-A1
Y=SIN(DA)*COS(B2)
X=SIN(B2)*COS(B1)-COS(B2)*SIN(B1)*COS(DA)
IF (X.NE.0.0.OR.Y.NE.0.0) THEN
sla_BEAR=ATAN2(Y,X)
ELSE
sla_BEAR=0.0
END IF
END

74
slalib/caf2r.f Normal file
View File

@ -0,0 +1,74 @@
SUBROUTINE sla_CAF2R (IDEG, IAMIN, ASEC, RAD, J)
*+
* - - - - - -
* C A F 2 R
* - - - - - -
*
* Convert degrees, arcminutes, arcseconds to radians
* (single precision)
*
* Given:
* IDEG int degrees
* IAMIN int arcminutes
* ASEC real arcseconds
*
* Returned:
* RAD real angle in radians
* J int status: 0 = OK
* 1 = IDEG outside range 0-359
* 2 = IAMIN outside range 0-59
* 3 = ASEC outside range 0-59.999...
*
* Notes:
*
* 1) The result is computed even if any of the range checks
* fail.
*
* 2) The sign must be dealt with outside this routine.
*
* P.T.Wallace Starlink 23 August 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IDEG,IAMIN
REAL ASEC,RAD
INTEGER J
* Arc seconds to radians
REAL AS2R
PARAMETER (AS2R=0.484813681109535994E-5)
* Preset status
J=0
* Validate arcsec, arcmin, deg
IF (ASEC.LT.0.0.OR.ASEC.GE.60.0) J=3
IF (IAMIN.LT.0.OR.IAMIN.GT.59) J=2
IF (IDEG.LT.0.OR.IDEG.GT.359) J=1
* Compute angle
RAD=AS2R*(60.0*(60.0*REAL(IDEG)+REAL(IAMIN))+ASEC)
END

74
slalib/caldj.f Normal file
View File

@ -0,0 +1,74 @@
SUBROUTINE sla_CALDJ (IY, IM, ID, DJM, J)
*+
* - - - - - -
* C A L D J
* - - - - - -
*
* Gregorian Calendar to Modified Julian Date
*
* (Includes century default feature: use sla_CLDJ for years
* before 100AD.)
*
* Given:
* IY,IM,ID int year, month, day in Gregorian calendar
*
* Returned:
* DJM dp modified Julian Date (JD-2400000.5) for 0 hrs
* J int status:
* 0 = OK
* 1 = bad year (MJD not computed)
* 2 = bad month (MJD not computed)
* 3 = bad day (MJD computed)
*
* Acceptable years are 00-49, interpreted as 2000-2049,
* 50-99, " " 1950-1999,
* 100 upwards, interpreted literally.
*
* Called: sla_CLDJ
*
* P.T.Wallace Starlink November 1985
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IY,IM,ID
DOUBLE PRECISION DJM
INTEGER J
INTEGER NY
* Default century if appropriate
IF (IY.GE.0.AND.IY.LE.49) THEN
NY=IY+2000
ELSE IF (IY.GE.50.AND.IY.LE.99) THEN
NY=IY+1900
ELSE
NY=IY
END IF
* Modified Julian Date
CALL sla_CLDJ(NY,IM,ID,DJM,J)
END

82
slalib/calyd.f Normal file
View File

@ -0,0 +1,82 @@
SUBROUTINE sla_CALYD (IY, IM, ID, NY, ND, J)
*+
* - - - - - -
* C A L Y D
* - - - - - -
*
* Gregorian calendar date to year and day in year (in a Julian
* calendar aligned to the 20th/21st century Gregorian calendar).
*
* (Includes century default feature: use sla_CLYD for years
* before 100AD.)
*
* Given:
* IY,IM,ID int year, month, day in Gregorian calendar
* (year may optionally omit the century)
* Returned:
* NY int year (re-aligned Julian calendar)
* ND int day in year (1 = January 1st)
* J int status:
* 0 = OK
* 1 = bad year (before -4711)
* 2 = bad month
* 3 = bad day (but conversion performed)
*
* Notes:
*
* 1 This routine exists to support the low-precision routines
* sla_EARTH, sla_MOON and sla_ECOR.
*
* 2 Between 1900 March 1 and 2100 February 28 it returns answers
* which are consistent with the ordinary Gregorian calendar.
* Outside this range there will be a discrepancy which increases
* by one day for every non-leap century year.
*
* 3 Years in the range 50-99 are interpreted as 1950-1999, and
* years in the range 00-49 are interpreted as 2000-2049.
*
* Called: sla_CLYD
*
* P.T.Wallace Starlink 23 November 1994
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IY,IM,ID,NY,ND,J
INTEGER I
* Default century if appropriate
IF (IY.GE.0.AND.IY.LE.49) THEN
I=IY+2000
ELSE IF (IY.GE.50.AND.IY.LE.99) THEN
I=IY+1900
ELSE
I=IY
END IF
* Perform the conversion
CALL sla_CLYD(I,IM,ID,NY,ND,J)
END

69
slalib/cc2s.f Normal file
View File

@ -0,0 +1,69 @@
SUBROUTINE sla_CC2S (V, A, B)
*+
* - - - - -
* C C 2 S
* - - - - -
*
* Cartesian to spherical coordinates (single precision)
*
* Given:
* V r(3) x,y,z vector
*
* Returned:
* A,B r spherical coordinates in radians
*
* The spherical coordinates are longitude (+ve anticlockwise looking
* from the +ve latitude pole) and latitude. The Cartesian coordinates
* are right handed, with the x axis at zero longitude and latitude, and
* the z axis at the +ve latitude pole.
*
* If V is null, zero A and B are returned. At either pole, zero A is
* returned.
*
* Last revision: 22 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL V(3),A,B
REAL X,Y,Z,R
X = V(1)
Y = V(2)
Z = V(3)
R = SQRT(X*X+Y*Y)
IF (R.EQ.0.0) THEN
A = 0.0
ELSE
A = ATAN2(Y,X)
END IF
IF (Z.EQ.0.0) THEN
B = 0.0
ELSE
B = ATAN2(Z,R)
END IF
END

99
slalib/cc62s.f Normal file
View File

@ -0,0 +1,99 @@
SUBROUTINE sla_CC62S (V, A, B, R, AD, BD, RD)
*+
* - - - - - -
* C C 6 2 S
* - - - - - -
*
* Conversion of position & velocity in Cartesian coordinates
* to spherical coordinates (single precision)
*
* Given:
* V r(6) Cartesian position & velocity vector
*
* Returned:
* A r longitude (radians)
* B r latitude (radians)
* R r radial coordinate
* AD r longitude derivative (radians per unit time)
* BD r latitude derivative (radians per unit time)
* RD r radial derivative
*
* P.T.Wallace Starlink 28 April 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL V(6),A,B,R,AD,BD,RD
REAL X,Y,Z,XD,YD,ZD,RXY2,RXY,R2,XYP
* Components of position/velocity vector
X=V(1)
Y=V(2)
Z=V(3)
XD=V(4)
YD=V(5)
ZD=V(6)
* Component of R in XY plane squared
RXY2=X*X+Y*Y
* Modulus squared
R2=RXY2+Z*Z
* Protection against null vector
IF (R2.EQ.0.0) THEN
X=XD
Y=YD
Z=ZD
RXY2=X*X+Y*Y
R2=RXY2+Z*Z
END IF
* Position and velocity in spherical coordinates
RXY=SQRT(RXY2)
XYP=X*XD+Y*YD
IF (RXY2.NE.0.0) THEN
A=ATAN2(Y,X)
B=ATAN2(Z,RXY)
AD=(X*YD-Y*XD)/RXY2
BD=(ZD*RXY2-Z*XYP)/(R2*RXY)
ELSE
A=0.0
IF (Z.NE.0.0) THEN
B=ATAN2(Z,RXY)
ELSE
B=0.0
END IF
AD=0.0
BD=0.0
END IF
R=SQRT(R2)
IF (R.NE.0.0) THEN
RD=(XYP+Z*ZD)/R
ELSE
RD=0.0
END IF
END

72
slalib/cd2tf.f Normal file
View File

@ -0,0 +1,72 @@
SUBROUTINE sla_CD2TF (NDP, DAYS, SIGN, IHMSF)
*+
* - - - - - -
* C D 2 T F
* - - - - - -
*
* Convert an interval in days into hours, minutes, seconds
*
* (single precision)
*
* Given:
* NDP int number of decimal places of seconds
* DAYS real interval in days
*
* Returned:
* SIGN char '+' or '-'
* IHMSF int(4) hours, minutes, seconds, fraction
*
* Notes:
*
* 1) NDP less than zero is interpreted as zero.
*
* 2) The largest useful value for NDP is determined by the size of
* DAYS, the format of REAL floating-point numbers on the target
* machine, and the risk of overflowing IHMSF(4). On some
* architectures, for DAYS up to 1.0, the available floating-
* point precision corresponds roughly to NDP=3. This is well
* below the ultimate limit of NDP=9 set by the capacity of a
* typical 32-bit IHMSF(4).
*
* 3) The absolute value of DAYS may exceed 1.0. In cases where it
* does not, it is up to the caller to test for and handle the
* case where DAYS is very nearly 1.0 and rounds up to 24 hours,
* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero.
*
* Called: sla_DD2TF
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NDP
REAL DAYS
CHARACTER SIGN*(*)
INTEGER IHMSF(4)
* Call double precision version
CALL sla_DD2TF(NDP,DBLE(DAYS),SIGN,IHMSF)
END

94
slalib/cldj.f Normal file
View File

@ -0,0 +1,94 @@
SUBROUTINE sla_CLDJ (IY, IM, ID, DJM, J)
*+
* - - - - -
* C L D J
* - - - - -
*
* Gregorian Calendar to Modified Julian Date
*
* Given:
* IY,IM,ID int year, month, day in Gregorian calendar
*
* Returned:
* DJM dp modified Julian Date (JD-2400000.5) for 0 hrs
* J int status:
* 0 = OK
* 1 = bad year (MJD not computed)
* 2 = bad month (MJD not computed)
* 3 = bad day (MJD computed)
*
* The year must be -4699 (i.e. 4700BC) or later.
*
* The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55).
*
* Last revision: 27 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IY,IM,ID
DOUBLE PRECISION DJM
INTEGER J
* Month lengths in days
INTEGER MTAB(12)
DATA MTAB / 31,28,31,30,31,30,31,31,30,31,30,31 /
* Preset status.
J = 0
* Validate year.
IF ( IY .LT. -4699 ) THEN
J = 1
ELSE
* Validate month.
IF ( IM.GE.1 .AND. IM.LE.12 ) THEN
* Allow for leap year.
IF ( MOD(IY,4) .EQ. 0 ) THEN
MTAB(2) = 29
ELSE
MTAB(2) = 28
END IF
IF ( MOD(IY,100).EQ.0 .AND. MOD(IY,400).NE.0 )
: MTAB(2) = 28
* Validate day.
IF ( ID.LT.1 .OR. ID.GT.MTAB(IM) ) J=3
* Modified Julian Date.
DJM = DBLE ( ( 1461 * ( IY - (12-IM)/10 + 4712 ) ) / 4
: + ( 306 * MOD ( IM+9, 12 ) + 5 ) / 10
: - ( 3 * ( ( IY - (12-IM)/10 + 4900 ) / 100 ) ) / 4
: + ID - 2399904 )
* Bad month.
ELSE
J=2
END IF
END IF
END

118
slalib/clyd.f Normal file
View File

@ -0,0 +1,118 @@
SUBROUTINE sla_CLYD (IY, IM, ID, NY, ND, JSTAT)
*+
* - - - - -
* C L Y D
* - - - - -
*
* Gregorian calendar to year and day in year (in a Julian calendar
* aligned to the 20th/21st century Gregorian calendar).
*
* Given:
* IY,IM,ID i year, month, day in Gregorian calendar
*
* Returned:
* NY i year (re-aligned Julian calendar)
* ND i day in year (1 = January 1st)
* JSTAT i status:
* 0 = OK
* 1 = bad year (before -4711)
* 2 = bad month
* 3 = bad day (but conversion performed)
*
* Notes:
*
* 1 This routine exists to support the low-precision routines
* sla_EARTH, sla_MOON and sla_ECOR.
*
* 2 Between 1900 March 1 and 2100 February 28 it returns answers
* which are consistent with the ordinary Gregorian calendar.
* Outside this range there will be a discrepancy which increases
* by one day for every non-leap century year.
*
* 3 The essence of the algorithm is first to express the Gregorian
* date as a Julian Day Number and then to convert this back to
* a Julian calendar date, with day-in-year instead of month and
* day. See 12.92-1 and 12.95-1 in the reference.
*
* Reference: Explanatory Supplement to the Astronomical Almanac,
* ed P.K.Seidelmann, University Science Books (1992),
* p604-606.
*
* P.T.Wallace Starlink 26 November 1994
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IY,IM,ID,NY,ND,JSTAT
INTEGER I,J,K,L,N
* Month lengths in days
INTEGER MTAB(12)
DATA MTAB/31,28,31,30,31,30,31,31,30,31,30,31/
* Preset status
JSTAT=0
* Validate year
IF (IY.GE.-4711) THEN
* Validate month
IF (IM.GE.1.AND.IM.LE.12) THEN
* Allow for (Gregorian) leap year
IF (MOD(IY,4).EQ.0.AND.
: (MOD(IY,100).NE.0.OR.MOD(IY,400).EQ.0)) THEN
MTAB(2)=29
ELSE
MTAB(2)=28
END IF
* Validate day
IF (ID.LT.1.OR.ID.GT.MTAB(IM)) JSTAT=3
* Perform the conversion
I=(14-IM)/12
K=IY-I
J=(1461*(K+4800))/4+(367*(IM-2+12*I))/12
: -(3*((K+4900)/100))/4+ID-30660
K=(J-1)/1461
L=J-1461*K
N=(L-1)/365-L/1461
J=((80*(L-365*N+30))/2447)/11
I=N+J
ND=59+L-365*I+((4-N)/4)*(1-J)
NY=4*K+I-4716
* Bad month
ELSE
JSTAT=2
END IF
ELSE
* Bad year
JSTAT=1
END IF
END

159
slalib/combn.f Normal file
View File

@ -0,0 +1,159 @@
SUBROUTINE sla_COMBN ( NSEL, NCAND, LIST, J )
*+
* - - - - - -
* C O M B N
* - - - - - -
*
* Generate the next combination, a subset of a specified size chosen
* from a specified number of items.
*
* Given:
* NSEL i number of items (subset size)
* NCAND i number of candidates (set size)
*
* Given and returned:
* LIST i(NSEL) latest combination, LIST(1)=0 to initialize
*
* Returned:
* J i status: -1 = illegal NSEL or NCAND
* 0 = OK
* +1 = no more combinations available
*
* Notes:
*
* 1) NSEL and NCAND must both be at least 1, and NSEL must be less
* than or equal to NCAND.
*
* 2) This routine returns, in the LIST array, a subset of NSEL integers
* chosen from the range 1 to NCAND inclusive, in ascending order.
* Before calling the routine for the first time, the caller must set
* the first element of the LIST array to zero (any value less than 1
* will do) to cause initialization.
*
* 2) The first combination to be generated is:
*
* LIST(1)=1, LIST(2)=2, ..., LIST(NSEL)=NSEL
*
* This is also the combination returned for the "finished" (J=1)
* case.
*
* The final permutation to be generated is:
*
* LIST(1)=NCAND, LIST(2)=NCAND-1, ..., LIST(NSEL)=NCAND-NSEL+1
*
* 3) If the "finished" (J=1) status is ignored, the routine
* continues to deliver combinations, the pattern repeating
* every NCAND!/(NSEL!*(NCAND-NSEL)!) calls.
*
* 4) The algorithm is by R.F.Warren-Smith (private communication).
*
* P.T.Wallace Starlink 25 August 1999
*
* Copyright (C) 1999 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NSEL,NCAND,LIST(NSEL),J
INTEGER I,LISTI,NMAX,M
LOGICAL MORE
* Validate, and set status.
IF (NSEL.LT.1.OR.NCAND.LT.1.OR.NSEL.GT.NCAND) THEN
J = -1
GO TO 9999
ELSE
J = 0
END IF
* Just starting?
IF (LIST(1).LT.1) THEN
* Yes: return 1,2,3...
DO I=1,NSEL
LIST(I) = I
END DO
ELSE
* No: find the first selection that we can increment.
* Start with the first list item.
I = 1
* Loop.
MORE = .TRUE.
DO WHILE (MORE)
* Current list item.
LISTI = LIST(I)
* Is this the final list item?
IF (I.GE.NSEL) THEN
* Yes: comparison value is number of candidates plus one.
NMAX = NCAND+1
ELSE
* No: comparison value is next list item.
NMAX = LIST(I+1)
END IF
* Can the current item be incremented?
IF (NMAX-LISTI.GT.1) THEN
* Yes: increment it.
LIST(I) = LISTI+1
* Reinitialize the preceding items.
DO M=1,I-1
LIST(M) = M
END DO
* Break.
MORE = .FALSE.
ELSE
* Can't increment the current item: is it the final one?
IF (I.GE.NSEL) THEN
* Yes: set the status.
J = 1
* Restart the sequence.
DO I=1,NSEL
LIST(I) = I
END DO
* Break.
MORE = .FALSE.
ELSE
* No: next list item.
I = I+1
END IF
END IF
END DO
END IF
9999 CONTINUE
END

75
slalib/cr2af.f Normal file
View File

@ -0,0 +1,75 @@
SUBROUTINE sla_CR2AF (NDP, ANGLE, SIGN, IDMSF)
*+
* - - - - - -
* C R 2 A F
* - - - - - -
*
* Convert an angle in radians into degrees, arcminutes, arcseconds
* (single precision)
*
* Given:
* NDP int number of decimal places of arcseconds
* ANGLE real angle in radians
*
* Returned:
* SIGN char '+' or '-'
* IDMSF int(4) degrees, arcminutes, arcseconds, fraction
*
* Notes:
*
* 1) NDP less than zero is interpreted as zero.
*
* 2) The largest useful value for NDP is determined by the size of
* ANGLE, the format of REAL floating-point numbers on the target
* machine, and the risk of overflowing IDMSF(4). On some
* architectures, for ANGLE up to 2pi, the available floating-
* point precision corresponds roughly to NDP=3. This is well
* below the ultimate limit of NDP=9 set by the capacity of a
* typical 32-bit IDMSF(4).
*
* 3) The absolute value of ANGLE may exceed 2pi. In cases where it
* does not, it is up to the caller to test for and handle the
* case where ANGLE is very nearly 2pi and rounds up to 360 deg,
* by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero.
*
* Called: sla_CD2TF
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NDP
REAL ANGLE
CHARACTER SIGN*(*)
INTEGER IDMSF(4)
* Hours to degrees * radians to turns
REAL F
PARAMETER (F=15.0/6.283185307179586476925287)
* Scale then use days to h,m,s routine
CALL sla_CD2TF(NDP,ANGLE*F,SIGN,IDMSF)
END

75
slalib/cr2tf.f Normal file
View File

@ -0,0 +1,75 @@
SUBROUTINE sla_CR2TF (NDP, ANGLE, SIGN, IHMSF)
*+
* - - - - - -
* C R 2 T F
* - - - - - -
*
* Convert an angle in radians into hours, minutes, seconds
* (single precision)
*
* Given:
* NDP int number of decimal places of seconds
* ANGLE real angle in radians
*
* Returned:
* SIGN char '+' or '-'
* IHMSF int(4) hours, minutes, seconds, fraction
*
* Notes:
*
* 1) NDP less than zero is interpreted as zero.
*
* 2) The largest useful value for NDP is determined by the size of
* ANGLE, the format of REAL floating-point numbers on the target
* machine, and the risk of overflowing IHMSF(4). On some
* architectures, for ANGLE up to 2pi, the available floating-point
* precision corresponds roughly to NDP=3. This is well below
* the ultimate limit of NDP=9 set by the capacity of a typical
* 32-bit IHMSF(4).
*
* 3) The absolute value of ANGLE may exceed 2pi. In cases where it
* does not, it is up to the caller to test for and handle the
* case where ANGLE is very nearly 2pi and rounds up to 24 hours,
* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero.
*
* Called: sla_CD2TF
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NDP
REAL ANGLE
CHARACTER SIGN*(*)
INTEGER IHMSF(4)
* Turns to radians
REAL T2R
PARAMETER (T2R=6.283185307179586476925287)
* Scale then use days to h,m,s routine
CALL sla_CD2TF(NDP,ANGLE/T2R,SIGN,IHMSF)
END

57
slalib/cs2c.f Normal file
View File

@ -0,0 +1,57 @@
SUBROUTINE sla_CS2C (A, B, V)
*+
* - - - - -
* C S 2 C
* - - - - -
*
* Spherical coordinates to direction cosines (single precision)
*
* Given:
* A,B real spherical coordinates in radians
* (RA,Dec), (long,lat) etc.
*
* Returned:
* V real(3) x,y,z unit vector
*
* The spherical coordinates are longitude (+ve anticlockwise looking
* from the +ve latitude pole) and latitude. The Cartesian coordinates
* are right handed, with the x axis at zero longitude and latitude, and
* the z axis at the +ve latitude pole.
*
* Last revision: 22 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL A,B,V(3)
REAL COSB
COSB = COS(B)
V(1) = COS(A)*COSB
V(2) = SIN(A)*COSB
V(3) = SIN(B)
END

72
slalib/cs2c6.f Normal file
View File

@ -0,0 +1,72 @@
SUBROUTINE sla_CS2C6 ( A, B, R, AD, BD, RD, V )
*+
* - - - - - -
* C S 2 C 6
* - - - - - -
*
* Conversion of position & velocity in spherical coordinates
* to Cartesian coordinates (single precision)
*
* Given:
* A r longitude (radians)
* B r latitude (radians)
* R r radial coordinate
* AD r longitude derivative (radians per unit time)
* BD r latitude derivative (radians per unit time)
* RD r radial derivative
*
* Returned:
* V r(6) Cartesian position & velocity vector
*
* Last revision: 11 September 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL A, B, R, AD, BD, RD, V(6)
REAL SA, CA, SB, CB, RCB, X, Y, RBD, W
* Useful functions.
SA = SIN(A)
CA = COS(A)
SB = SIN(B)
CB = COS(B)
RCB = R*CB
X = RCB*CA
Y = RCB*SA
RBD = R*BD
W = RBD*SB-CB*RD
* Position.
V(1) = X
V(2) = Y
V(3) = R*SB
* Velocity.
V(4) = -Y*AD-W*CA
V(5) = X*AD-W*SA
V(6) = RBD*CB+SB*RD
END

73
slalib/ctf2d.f Normal file
View File

@ -0,0 +1,73 @@
SUBROUTINE sla_CTF2D (IHOUR, IMIN, SEC, DAYS, J)
*+
* - - - - - -
* C T F 2 D
* - - - - - -
*
* Convert hours, minutes, seconds to days (single precision)
*
* Given:
* IHOUR int hours
* IMIN int minutes
* SEC real seconds
*
* Returned:
* DAYS real interval in days
* J int status: 0 = OK
* 1 = IHOUR outside range 0-23
* 2 = IMIN outside range 0-59
* 3 = SEC outside range 0-59.999...
*
* Notes:
*
* 1) The result is computed even if any of the range checks
* fail.
*
* 2) The sign must be dealt with outside this routine.
*
* P.T.Wallace Starlink November 1984
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IHOUR,IMIN
REAL SEC,DAYS
INTEGER J
* Seconds per day
REAL D2S
PARAMETER (D2S=86400.0)
* Preset status
J=0
* Validate sec, min, hour
IF (SEC.LT.0.0.OR.SEC.GE.60.0) J=3
IF (IMIN.LT.0.OR.IMIN.GT.59) J=2
IF (IHOUR.LT.0.OR.IHOUR.GT.23) J=1
* Compute interval
DAYS=(60.0*(60.0*REAL(IHOUR)+REAL(IMIN))+SEC)/D2S
END

71
slalib/ctf2r.f Normal file
View File

@ -0,0 +1,71 @@
SUBROUTINE sla_CTF2R (IHOUR, IMIN, SEC, RAD, J)
*+
* - - - - - -
* C T F 2 R
* - - - - - -
*
* Convert hours, minutes, seconds to radians (single precision)
*
* Given:
* IHOUR int hours
* IMIN int minutes
* SEC real seconds
*
* Returned:
* RAD real angle in radians
* J int status: 0 = OK
* 1 = IHOUR outside range 0-23
* 2 = IMIN outside range 0-59
* 3 = SEC outside range 0-59.999...
*
* Called:
* sla_CTF2D
*
* Notes:
*
* 1) The result is computed even if any of the range checks
* fail.
*
* 2) The sign must be dealt with outside this routine.
*
* P.T.Wallace Starlink November 1984
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IHOUR,IMIN
REAL SEC,RAD
INTEGER J
REAL TURNS
* Turns to radians
REAL T2R
PARAMETER (T2R=6.283185307179586476925287)
* Convert to turns then radians
CALL sla_CTF2D(IHOUR,IMIN,SEC,TURNS,J)
RAD=T2R*TURNS
END

72
slalib/daf2r.f Normal file
View File

@ -0,0 +1,72 @@
SUBROUTINE sla_DAF2R (IDEG, IAMIN, ASEC, RAD, J)
*+
* - - - - - -
* D A F 2 R
* - - - - - -
*
* Convert degrees, arcminutes, arcseconds to radians
* (double precision)
*
* Given:
* IDEG int degrees
* IAMIN int arcminutes
* ASEC dp arcseconds
*
* Returned:
* RAD dp angle in radians
* J int status: 0 = OK
* 1 = IDEG outside range 0-359
* 2 = IAMIN outside range 0-59
* 3 = ASEC outside range 0-59.999...
*
* Notes:
* 1) The result is computed even if any of the range checks
* fail.
* 2) The sign must be dealt with outside this routine.
*
* P.T.Wallace Starlink 23 August 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IDEG,IAMIN
DOUBLE PRECISION ASEC,RAD
INTEGER J
* Arc seconds to radians
DOUBLE PRECISION AS2R
PARAMETER (AS2R=0.484813681109535994D-5)
* Preset status
J=0
* Validate arcsec, arcmin, deg
IF (ASEC.LT.0D0.OR.ASEC.GE.60D0) J=3
IF (IAMIN.LT.0.OR.IAMIN.GT.59) J=2
IF (IDEG.LT.0.OR.IDEG.GT.359) J=1
* Compute angle
RAD=AS2R*(60D0*(60D0*DBLE(IDEG)+DBLE(IAMIN))+ASEC)
END

180
slalib/dafin.f Normal file
View File

@ -0,0 +1,180 @@
SUBROUTINE sla_DAFIN (STRING, IPTR, A, J)
*+
* - - - - - -
* D A F I N
* - - - - - -
*
* Sexagesimal character string to angle (double precision)
*
* Given:
* STRING c*(*) string containing deg, arcmin, arcsec fields
* IPTR i pointer to start of decode (1st = 1)
*
* Returned:
* IPTR i advanced past the decoded angle
* A d angle in radians
* J i status: 0 = OK
* +1 = default, A unchanged
* -1 = bad degrees )
* -2 = bad arcminutes ) (note 3)
* -3 = bad arcseconds )
*
* Example:
*
* argument before after
*
* STRING '-57 17 44.806 12 34 56.7' unchanged
* IPTR 1 16 (points to 12...)
* A ? -1.00000D0
* J ? 0
*
* A further call to sla_DAFIN, without adjustment of IPTR, will
* decode the second angle, 12deg 34min 56.7sec.
*
* Notes:
*
* 1) The first three "fields" in STRING are degrees, arcminutes,
* arcseconds, separated by spaces or commas. The degrees field
* may be signed, but not the others. The decoding is carried
* out by the DFLTIN routine and is free-format.
*
* 2) Successive fields may be absent, defaulting to zero. For
* zero status, the only combinations allowed are degrees alone,
* degrees and arcminutes, and all three fields present. If all
* three fields are omitted, a status of +1 is returned and A is
* unchanged. In all other cases A is changed.
*
* 3) Range checking:
*
* The degrees field is not range checked. However, it is
* expected to be integral unless the other two fields are absent.
*
* The arcminutes field is expected to be 0-59, and integral if
* the arcseconds field is present. If the arcseconds field
* is absent, the arcminutes is expected to be 0-59.9999...
*
* The arcseconds field is expected to be 0-59.9999...
*
* 4) Decoding continues even when a check has failed. Under these
* circumstances the field takes the supplied value, defaulting
* to zero, and the result A is computed and returned.
*
* 5) Further fields after the three expected ones are not treated
* as an error. The pointer IPTR is left in the correct state
* for further decoding with the present routine or with DFLTIN
* etc. See the example, above.
*
* 6) If STRING contains hours, minutes, seconds instead of degrees
* etc, or if the required units are turns (or days) instead of
* radians, the result A should be multiplied as follows:
*
* for to obtain multiply
* STRING A in A by
*
* d ' " radians 1 = 1D0
* d ' " turns 1/2pi = 0.1591549430918953358D0
* h m s radians 15 = 15D0
* h m s days 15/2pi = 2.3873241463784300365D0
*
* Called: sla_DFLTIN
*
* P.T.Wallace Starlink 1 August 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
CHARACTER*(*) STRING
INTEGER IPTR
DOUBLE PRECISION A
INTEGER J
DOUBLE PRECISION AS2R
PARAMETER (AS2R=4.84813681109535993589914102358D-6)
INTEGER JF,JD,JM,JS
DOUBLE PRECISION DEG,ARCMIN,ARCSEC
* Preset the status to OK
JF=0
* Defaults
DEG=0D0
ARCMIN=0D0
ARCSEC=0D0
* Decode degrees, arcminutes, arcseconds
CALL sla_DFLTIN(STRING,IPTR,DEG,JD)
IF (JD.GT.1) THEN
JF=-1
ELSE
CALL sla_DFLTIN(STRING,IPTR,ARCMIN,JM)
IF (JM.LT.0.OR.JM.GT.1) THEN
JF=-2
ELSE
CALL sla_DFLTIN(STRING,IPTR,ARCSEC,JS)
IF (JS.LT.0.OR.JS.GT.1) THEN
JF=-3
* See if the combination of fields is credible
ELSE IF (JD.GT.0) THEN
* No degrees: arcmin, arcsec ought also to be absent
IF (JM.EQ.0) THEN
* Suspect arcmin
JF=-2
ELSE IF (JS.EQ.0) THEN
* Suspect arcsec
JF=-3
ELSE
* All three fields absent
JF=1
END IF
* Degrees present: if arcsec present so ought arcmin to be
ELSE IF (JM.NE.0.AND.JS.EQ.0) THEN
JF=-3
* Tests for range and integrality
* Degrees
ELSE IF (JM.EQ.0.AND.DINT(DEG).NE.DEG) THEN
JF=-1
* Arcminutes
ELSE IF ((JS.EQ.0.AND.DINT(ARCMIN).NE.ARCMIN).OR.
: ARCMIN.GE.60D0) THEN
JF=-2
* Arcseconds
ELSE IF (ARCSEC.GE.60D0) THEN
JF=-3
END IF
END IF
END IF
* Unless all three fields absent, compute angle value
IF (JF.LE.0) THEN
A=AS2R*(60D0*(60D0*ABS(DEG)+ARCMIN)+ARCSEC)
IF (JD.LT.0) A=-A
END IF
* Return the status
J=JF
END

252
slalib/dat.f Normal file
View File

@ -0,0 +1,252 @@
DOUBLE PRECISION FUNCTION sla_DAT (UTC)
*+
* - - - -
* D A T
* - - - -
*
* Increment to be applied to Coordinated Universal Time UTC to give
* International Atomic Time TAI (double precision)
*
* Given:
* UTC d UTC date as a modified JD (JD-2400000.5)
*
* Result: TAI-UTC in seconds
*
* Notes:
*
* 1 The UTC is specified to be a date rather than a time to indicate
* that care needs to be taken not to specify an instant which lies
* within a leap second. Though in most cases UTC can include the
* fractional part, correct behaviour on the day of a leap second
* can only be guaranteed up to the end of the second 23:59:59.
*
* 2 For epochs from 1961 January 1 onwards, the expressions from the
* file ftp://maia.usno.navy.mil/ser7/tai-utc.dat are used.
*
* 3 The 5ms time step at 1961 January 1 is taken from 2.58.1 (p87) of
* the 1992 Explanatory Supplement.
*
* 4 UTC began at 1960 January 1.0 (JD 2436934.5) and it is improper
* to call the routine with an earlier epoch. However, if this
* is attempted, the TAI-UTC expression for the year 1960 is used.
*
*
* :-----------------------------------------:
* : :
* : IMPORTANT :
* : :
* : This routine must be updated on each :
* : occasion that a leap second is :
* : announced :
* : :
* : Latest leap second: 2015 July 1 :
* : :
* :-----------------------------------------:
*
* Last revision: 31 January 2015
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION UTC
DOUBLE PRECISION DT
IF (.FALSE.) THEN
* - - - - - - - - - - - - - - - - - - - - - - *
* Add new code here on each occasion that a *
* leap second is announced, and update the *
* preamble comments appropriately. *
* - - - - - - - - - - - - - - - - - - - - - - *
* 2015 July 1
ELSE IF (UTC.GE.57204D0) THEN
DT=36D0
* 2012 July 1
ELSE IF (UTC.GE.56109D0) THEN
DT=35D0
* 2009 January 1
ELSE IF (UTC.GE.54832D0) THEN
DT=34D0
* 2006 January 1
ELSE IF (UTC.GE.53736D0) THEN
DT=33D0
* 1999 January 1
ELSE IF (UTC.GE.51179D0) THEN
DT=32D0
* 1997 July 1
ELSE IF (UTC.GE.50630D0) THEN
DT=31D0
* 1996 January 1
ELSE IF (UTC.GE.50083D0) THEN
DT=30D0
* 1994 July 1
ELSE IF (UTC.GE.49534D0) THEN
DT=29D0
* 1993 July 1
ELSE IF (UTC.GE.49169D0) THEN
DT=28D0
* 1992 July 1
ELSE IF (UTC.GE.48804D0) THEN
DT=27D0
* 1991 January 1
ELSE IF (UTC.GE.48257D0) THEN
DT=26D0
* 1990 January 1
ELSE IF (UTC.GE.47892D0) THEN
DT=25D0
* 1988 January 1
ELSE IF (UTC.GE.47161D0) THEN
DT=24D0
* 1985 July 1
ELSE IF (UTC.GE.46247D0) THEN
DT=23D0
* 1983 July 1
ELSE IF (UTC.GE.45516D0) THEN
DT=22D0
* 1982 July 1
ELSE IF (UTC.GE.45151D0) THEN
DT=21D0
* 1981 July 1
ELSE IF (UTC.GE.44786D0) THEN
DT=20D0
* 1980 January 1
ELSE IF (UTC.GE.44239D0) THEN
DT=19D0
* 1979 January 1
ELSE IF (UTC.GE.43874D0) THEN
DT=18D0
* 1978 January 1
ELSE IF (UTC.GE.43509D0) THEN
DT=17D0
* 1977 January 1
ELSE IF (UTC.GE.43144D0) THEN
DT=16D0
* 1976 January 1
ELSE IF (UTC.GE.42778D0) THEN
DT=15D0
* 1975 January 1
ELSE IF (UTC.GE.42413D0) THEN
DT=14D0
* 1974 January 1
ELSE IF (UTC.GE.42048D0) THEN
DT=13D0
* 1973 January 1
ELSE IF (UTC.GE.41683D0) THEN
DT=12D0
* 1972 July 1
ELSE IF (UTC.GE.41499D0) THEN
DT=11D0
* 1972 January 1
ELSE IF (UTC.GE.41317D0) THEN
DT=10D0
* 1968 February 1
ELSE IF (UTC.GE.39887D0) THEN
DT=4.2131700D0+(UTC-39126D0)*0.002592D0
* 1966 January 1
ELSE IF (UTC.GE.39126D0) THEN
DT=4.3131700D0+(UTC-39126D0)*0.002592D0
* 1965 September 1
ELSE IF (UTC.GE.39004D0) THEN
DT=3.8401300D0+(UTC-38761D0)*0.001296D0
* 1965 July 1
ELSE IF (UTC.GE.38942D0) THEN
DT=3.7401300D0+(UTC-38761D0)*0.001296D0
* 1965 March 1
ELSE IF (UTC.GE.38820D0) THEN
DT=3.6401300D0+(UTC-38761D0)*0.001296D0
* 1965 January 1
ELSE IF (UTC.GE.38761D0) THEN
DT=3.5401300D0+(UTC-38761D0)*0.001296D0
* 1964 September 1
ELSE IF (UTC.GE.38639D0) THEN
DT=3.4401300D0+(UTC-38761D0)*0.001296D0
* 1964 April 1
ELSE IF (UTC.GE.38486D0) THEN
DT=3.3401300D0+(UTC-38761D0)*0.001296D0
* 1964 January 1
ELSE IF (UTC.GE.38395D0) THEN
DT=3.2401300D0+(UTC-38761D0)*0.001296D0
* 1963 November 1
ELSE IF (UTC.GE.38334D0) THEN
DT=1.9458580D0+(UTC-37665D0)*0.0011232D0
* 1962 January 1
ELSE IF (UTC.GE.37665D0) THEN
DT=1.8458580D0+(UTC-37665D0)*0.0011232D0
* 1961 August 1
ELSE IF (UTC.GE.37512D0) THEN
DT=1.3728180D0+(UTC-37300D0)*0.001296D0
* 1961 January 1
ELSE IF (UTC.GE.37300D0) THEN
DT=1.4228180D0+(UTC-37300D0)*0.001296D0
* Before that
ELSE
DT=1.4178180D0+(UTC-37300D0)*0.001296D0
END IF
sla_DAT=DT
END

83
slalib/dav2m.f Normal file
View File

@ -0,0 +1,83 @@
SUBROUTINE sla_DAV2M (AXVEC, RMAT)
*+
* - - - - - -
* D A V 2 M
* - - - - - -
*
* Form the rotation matrix corresponding to a given axial vector.
* (double precision)
*
* A rotation matrix describes a rotation about some arbitrary axis,
* called the Euler axis. The "axial vector" supplied to this routine
* has the same direction as the Euler axis, and its magnitude is the
* amount of rotation in radians.
*
* Given:
* AXVEC d(3) axial vector (radians)
*
* Returned:
* RMAT d(3,3) rotation matrix
*
* If AXVEC is null, the unit matrix is returned.
*
* The reference frame rotates clockwise as seen looking along
* the axial vector from the origin.
*
* Last revision: 26 November 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION AXVEC(3),RMAT(3,3)
DOUBLE PRECISION X,Y,Z,PHI,S,C,W
* Rotation angle - magnitude of axial vector - and functions
X = AXVEC(1)
Y = AXVEC(2)
Z = AXVEC(3)
PHI = SQRT(X*X+Y*Y+Z*Z)
S = SIN(PHI)
C = COS(PHI)
W = 1D0-C
* Euler axis - direction of axial vector (perhaps null)
IF (PHI.NE.0D0) THEN
X = X/PHI
Y = Y/PHI
Z = Z/PHI
END IF
* Compute the rotation matrix
RMAT(1,1) = X*X*W+C
RMAT(1,2) = X*Y*W+Z*S
RMAT(1,3) = X*Z*W-Y*S
RMAT(2,1) = X*Y*W-Z*S
RMAT(2,2) = Y*Y*W+C
RMAT(2,3) = Y*Z*W+X*S
RMAT(3,1) = X*Z*W+Y*S
RMAT(3,2) = Y*Z*W-X*S
RMAT(3,3) = Z*Z*W+C
END

59
slalib/dbear.f Normal file
View File

@ -0,0 +1,59 @@
DOUBLE PRECISION FUNCTION sla_DBEAR (A1, B1, A2, B2)
*+
* - - - - - -
* D B E A R
* - - - - - -
*
* Bearing (position angle) of one point on a sphere relative to another
* (double precision)
*
* Given:
* A1,B1 d spherical coordinates of one point
* A2,B2 d spherical coordinates of the other point
*
* (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.)
*
* The result is the bearing (position angle), in radians, of point
* A2,B2 as seen from point A1,B1. It is in the range +/- pi. If
* A2,B2 is due east of A1,B1 the bearing is +pi/2. Zero is returned
* if the two points are coincident.
*
* P.T.Wallace Starlink 23 March 1991
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION A1,B1,A2,B2
DOUBLE PRECISION DA,X,Y
DA=A2-A1
Y=SIN(DA)*COS(B2)
X=SIN(B2)*COS(B1)-COS(B2)*SIN(B1)*COS(DA)
IF (X.NE.0D0.OR.Y.NE.0D0) THEN
sla_DBEAR=ATAN2(Y,X)
ELSE
sla_DBEAR=0D0
END IF
END

130
slalib/dbjin.f Normal file
View File

@ -0,0 +1,130 @@
SUBROUTINE sla_DBJIN (STRING, NSTRT, DRESLT, J1, J2)
*+
* - - - - - -
* D B J I N
* - - - - - -
*
* Convert free-format input into double precision floating point,
* using DFLTIN but with special syntax extensions.
*
* The purpose of the syntax extensions is to help cope with mixed
* FK4 and FK5 data. In addition to the syntax accepted by DFLTIN,
* the following two extensions are recognized by DBJIN:
*
* 1) A valid non-null field preceded by the character 'B'
* (or 'b') is accepted.
*
* 2) A valid non-null field preceded by the character 'J'
* (or 'j') is accepted.
*
* The calling program is notified of the incidence of either of these
* extensions through an supplementary status argument. The rest of
* the arguments are as for DFLTIN.
*
* Given:
* STRING char string containing field to be decoded
* NSTRT int pointer to 1st character of field in string
*
* Returned:
* NSTRT int incremented
* DRESLT double result
* J1 int DFLTIN status: -1 = -OK
* 0 = +OK
* +1 = null field
* +2 = error
* J2 int syntax flag: 0 = normal DFLTIN syntax
* +1 = 'B' or 'b'
* +2 = 'J' or 'j'
*
* Called: sla_DFLTIN
*
* For details of the basic syntax, see sla_DFLTIN.
*
* P.T.Wallace Starlink 23 November 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
CHARACTER*(*) STRING
INTEGER NSTRT
DOUBLE PRECISION DRESLT
INTEGER J1,J2
INTEGER J2A,LENSTR,NA,J1A,NB,J1B
CHARACTER C
* Preset syntax flag
J2A=0
* Length of string
LENSTR=LEN(STRING)
* Pointer to current character
NA=NSTRT
* Attempt normal decode
CALL sla_DFLTIN(STRING,NA,DRESLT,J1A)
* Proceed only if pointer still within string
IF (NA.GE.1.AND.NA.LE.LENSTR) THEN
* See if DFLTIN reported a null field
IF (J1A.EQ.1) THEN
* It did: examine character it stuck on
C=STRING(NA:NA)
IF (C.EQ.'B'.OR.C.EQ.'b') THEN
* 'B' - provisionally note
J2A=1
ELSE IF (C.EQ.'J'.OR.C.EQ.'j') THEN
* 'J' - provisionally note
J2A=2
END IF
* Following B or J, attempt to decode a number
IF (J2A.EQ.1.OR.J2A.EQ.2) THEN
NB=NA+1
CALL sla_DFLTIN(STRING,NB,DRESLT,J1B)
* If successful, copy pointer and status
IF (J1B.LE.0) THEN
NA=NB
J1A=J1B
* If not, forget about the B or J
ELSE
J2A=0
END IF
END IF
END IF
END IF
* Return argument values and exit
NSTRT=NA
J1=J1A
J2=J2A
END

99
slalib/dc62s.f Normal file
View File

@ -0,0 +1,99 @@
SUBROUTINE sla_DC62S (V, A, B, R, AD, BD, RD)
*+
* - - - - - -
* D C 6 2 S
* - - - - - -
*
* Conversion of position & velocity in Cartesian coordinates
* to spherical coordinates (double precision)
*
* Given:
* V d(6) Cartesian position & velocity vector
*
* Returned:
* A d longitude (radians)
* B d latitude (radians)
* R d radial coordinate
* AD d longitude derivative (radians per unit time)
* BD d latitude derivative (radians per unit time)
* RD d radial derivative
*
* P.T.Wallace Starlink 28 April 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION V(6),A,B,R,AD,BD,RD
DOUBLE PRECISION X,Y,Z,XD,YD,ZD,RXY2,RXY,R2,XYP
* Components of position/velocity vector
X=V(1)
Y=V(2)
Z=V(3)
XD=V(4)
YD=V(5)
ZD=V(6)
* Component of R in XY plane squared
RXY2=X*X+Y*Y
* Modulus squared
R2=RXY2+Z*Z
* Protection against null vector
IF (R2.EQ.0D0) THEN
X=XD
Y=YD
Z=ZD
RXY2=X*X+Y*Y
R2=RXY2+Z*Z
END IF
* Position and velocity in spherical coordinates
RXY=SQRT(RXY2)
XYP=X*XD+Y*YD
IF (RXY2.NE.0D0) THEN
A=ATAN2(Y,X)
B=ATAN2(Z,RXY)
AD=(X*YD-Y*XD)/RXY2
BD=(ZD*RXY2-Z*XYP)/(R2*RXY)
ELSE
A=0D0
IF (Z.NE.0D0) THEN
B=ATAN2(Z,RXY)
ELSE
B=0D0
END IF
AD=0D0
BD=0D0
END IF
R=SQRT(R2)
IF (R.NE.0D0) THEN
RD=(XYP+Z*ZD)/R
ELSE
RD=0D0
END IF
END

69
slalib/dcc2s.f Normal file
View File

@ -0,0 +1,69 @@
SUBROUTINE sla_DCC2S (V, A, B)
*+
* - - - - - -
* D C C 2 S
* - - - - - -
*
* Cartesian to spherical coordinates (double precision)
*
* Given:
* V d(3) x,y,z vector
*
* Returned:
* A,B d spherical coordinates in radians
*
* The spherical coordinates are longitude (+ve anticlockwise looking
* from the +ve latitude pole) and latitude. The Cartesian coordinates
* are right handed, with the x axis at zero longitude and latitude, and
* the z axis at the +ve latitude pole.
*
* If V is null, zero A and B are returned. At either pole, zero A is
* returned.
*
* Last revision: 22 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION V(3),A,B
DOUBLE PRECISION X,Y,Z,R
X = V(1)
Y = V(2)
Z = V(3)
R = SQRT(X*X+Y*Y)
IF (R.EQ.0D0) THEN
A = 0D0
ELSE
A = ATAN2(Y,X)
END IF
IF (Z.EQ.0D0) THEN
B = 0D0
ELSE
B = ATAN2(Z,R)
END IF
END

159
slalib/dcmpf.f Normal file
View File

@ -0,0 +1,159 @@
SUBROUTINE sla_DCMPF (COEFFS,XZ,YZ,XS,YS,PERP,ORIENT)
*+
* - - - - - -
* D C M P F
* - - - - - -
*
* Decompose an [X,Y] linear fit into its constituent parameters:
* zero points, scales, nonperpendicularity and orientation.
*
* Given:
* COEFFS d(6) transformation coefficients (see note)
*
* Returned:
* XZ d x zero point
* YZ d y zero point
* XS d x scale
* YS d y scale
* PERP d nonperpendicularity (radians)
* ORIENT d orientation (radians)
*
* Called: sla_DRANGE
*
* The model relates two sets of [X,Y] coordinates as follows.
* Naming the elements of COEFFS:
*
* COEFFS(1) = A
* COEFFS(2) = B
* COEFFS(3) = C
* COEFFS(4) = D
* COEFFS(5) = E
* COEFFS(6) = F
*
* the model transforms coordinates [X1,Y1] into coordinates
* [X2,Y2] as follows:
*
* X2 = A + B*X1 + C*Y1
* Y2 = D + E*X1 + F*Y1
*
* The transformation can be decomposed into four steps:
*
* 1) Zero points:
*
* x' = XZ + X1
* y' = YZ + Y1
*
* 2) Scales:
*
* x'' = XS*x'
* y'' = YS*y'
*
* 3) Nonperpendicularity:
*
* x''' = cos(PERP/2)*x'' + sin(PERP/2)*y''
* y''' = sin(PERP/2)*x'' + cos(PERP/2)*y''
*
* 4) Orientation:
*
* X2 = cos(ORIENT)*x''' + sin(ORIENT)*y'''
* Y2 =-sin(ORIENT)*y''' + cos(ORIENT)*y'''
*
* See also sla_FITXY, sla_PXY, sla_INVF, sla_XY2XY
*
* P.T.Wallace Starlink 19 December 2001
*
* Copyright (C) 2001 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION COEFFS(6),XZ,YZ,XS,YS,PERP,ORIENT
DOUBLE PRECISION A,B,C,D,E,F,RB2E2,RC2F2,XSC,YSC,P1,P2,P,WS,WC,
: OR,HP,SHP,CHP,SOR,COR,DET,X0,Y0,sla_DRANGE
* Copy the six coefficients.
A = COEFFS(1)
B = COEFFS(2)
C = COEFFS(3)
D = COEFFS(4)
E = COEFFS(5)
F = COEFFS(6)
* Scales.
RB2E2 = SQRT(B*B+E*E)
RC2F2 = SQRT(C*C+F*F)
IF (B*F-C*E.GE.0D0) THEN
XSC = RB2E2
ELSE
B = -B
E = -E
XSC = -RB2E2
END IF
YSC = RC2F2
* Non-perpendicularity.
IF (C.NE.0D0.OR.F.NE.0D0) THEN
P1 = ATAN2(C,F)
ELSE
P1 = 0D0
END IF
IF (E.NE.0D0.OR.B.NE.0D0) THEN
P2 = ATAN2(E,B)
ELSE
P2 = 0D0
END IF
P = sla_DRANGE(P1+P2)
* Orientation.
WS = C*RB2E2-E*RC2F2
WC = B*RC2F2+F*RB2E2
IF (WS.NE.0D0.OR.WC.NE.0D0) THEN
OR = ATAN2(WS,WC)
ELSE
OR = 0D0
END IF
* Zero points.
HP = P/2D0
SHP = SIN(HP)
CHP = COS(HP)
SOR = SIN(OR)
COR = COS(OR)
DET = XSC*YSC*(CHP+SHP)*(CHP-SHP)
IF (ABS(DET).GT.0D0) THEN
X0 = YSC*(A*(CHP*COR-SHP*SOR)-D*(CHP*SOR+SHP*COR))/DET
Y0 = XSC*(A*(CHP*SOR-SHP*COR)+D*(CHP*COR+SHP*SOR))/DET
ELSE
X0 = 0D0
Y0 = 0D0
END IF
* Results.
XZ = X0
YZ = Y0
XS = XSC
YS = YSC
PERP = P
ORIENT = OR
END

56
slalib/dcs2c.f Normal file
View File

@ -0,0 +1,56 @@
SUBROUTINE sla_DCS2C (A, B, V)
*+
* - - - - - -
* D C S 2 C
* - - - - - -
*
* Spherical coordinates to direction cosines (double precision)
*
* Given:
* A,B d spherical coordinates in radians
* (RA,Dec), (long,lat) etc.
*
* Returned:
* V d(3) x,y,z unit vector
*
* The spherical coordinates are longitude (+ve anticlockwise looking
* from the +ve latitude pole) and latitude. The Cartesian coordinates
* are right handed, with the x axis at zero longitude and latitude, and
* the z axis at the +ve latitude pole.
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION A,B,V(3)
DOUBLE PRECISION COSB
COSB = COS(B)
V(1) = COS(A)*COSB
V(2) = SIN(A)*COSB
V(3) = SIN(B)
END

106
slalib/dd2tf.f Normal file
View File

@ -0,0 +1,106 @@
SUBROUTINE sla_DD2TF (NDP, DAYS, SIGN, IHMSF)
*+
* - - - - - -
* D D 2 T F
* - - - - - -
*
* Convert an interval in days into hours, minutes, seconds
* (double precision)
*
* Given:
* NDP i number of decimal places of seconds
* DAYS d interval in days
*
* Returned:
* SIGN c '+' or '-'
* IHMSF i(4) hours, minutes, seconds, fraction
*
* Notes:
*
* 1) NDP less than zero is interpreted as zero.
*
* 2) The largest useful value for NDP is determined by the size
* of DAYS, the format of DOUBLE PRECISION floating-point numbers
* on the target machine, and the risk of overflowing IHMSF(4).
* On some architectures, for DAYS up to 1D0, the available
* floating-point precision corresponds roughly to NDP=12.
* However, the practical limit is NDP=9, set by the capacity of
* a typical 32-bit IHMSF(4).
*
* 3) The absolute value of DAYS may exceed 1D0. In cases where it
* does not, it is up to the caller to test for and handle the
* case where DAYS is very nearly 1D0 and rounds up to 24 hours,
* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero.
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NDP
DOUBLE PRECISION DAYS
CHARACTER SIGN*(*)
INTEGER IHMSF(4)
* Days to seconds
DOUBLE PRECISION D2S
PARAMETER (D2S=86400D0)
INTEGER NRS,N
DOUBLE PRECISION RS,RM,RH,A,AH,AM,AS,AF
* Handle sign
IF (DAYS.GE.0D0) THEN
SIGN='+'
ELSE
SIGN='-'
END IF
* Field units in terms of least significant figure
NRS=1
DO N=1,NDP
NRS=NRS*10
END DO
RS=DBLE(NRS)
RM=RS*60D0
RH=RM*60D0
* Round interval and express in smallest units required
A=ANINT(RS*D2S*ABS(DAYS))
* Separate into fields
AH=AINT(A/RH)
A=A-AH*RH
AM=AINT(A/RM)
A=A-AM*RM
AS=AINT(A/RS)
AF=A-AS*RS
* Return results
IHMSF(1)=MAX(NINT(AH),0)
IHMSF(2)=MAX(MIN(NINT(AM),59),0)
IHMSF(3)=MAX(MIN(NINT(AS),59),0)
IHMSF(4)=MAX(NINT(MIN(AF,RS-1D0)),0)
END

106
slalib/de2h.f Normal file
View File

@ -0,0 +1,106 @@
SUBROUTINE sla_DE2H (HA, DEC, PHI, AZ, EL)
*+
* - - - - -
* D E 2 H
* - - - - -
*
* Equatorial to horizon coordinates: HA,Dec to Az,El
*
* (double precision)
*
* Given:
* HA d hour angle
* DEC d declination
* PHI d observatory latitude
*
* Returned:
* AZ d azimuth
* EL d elevation
*
* Notes:
*
* 1) All the arguments are angles in radians.
*
* 2) Azimuth is returned in the range 0-2pi; north is zero,
* and east is +pi/2. Elevation is returned in the range
* +/-pi/2.
*
* 3) The latitude must be geodetic. In critical applications,
* corrections for polar motion should be applied.
*
* 4) In some applications it will be important to specify the
* correct type of hour angle and declination in order to
* produce the required type of azimuth and elevation. In
* particular, it may be important to distinguish between
* elevation as affected by refraction, which would
* require the "observed" HA,Dec, and the elevation
* in vacuo, which would require the "topocentric" HA,Dec.
* If the effects of diurnal aberration can be neglected, the
* "apparent" HA,Dec may be used instead of the topocentric
* HA,Dec.
*
* 5) No range checking of arguments is carried out.
*
* 6) In applications which involve many such calculations, rather
* than calling the present routine it will be more efficient to
* use inline code, having previously computed fixed terms such
* as sine and cosine of latitude, and (for tracking a star)
* sine and cosine of declination.
*
* P.T.Wallace Starlink 9 July 1994
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION HA,DEC,PHI,AZ,EL
DOUBLE PRECISION D2PI
PARAMETER (D2PI=6.283185307179586476925286766559D0)
DOUBLE PRECISION SH,CH,SD,CD,SP,CP,X,Y,Z,R,A
* Useful trig functions
SH=SIN(HA)
CH=COS(HA)
SD=SIN(DEC)
CD=COS(DEC)
SP=SIN(PHI)
CP=COS(PHI)
* Az,El as x,y,z
X=-CH*CD*SP+SD*CP
Y=-SH*CD
Z=CH*CD*CP+SD*SP
* To spherical
R=SQRT(X*X+Y*Y)
IF (R.EQ.0D0) THEN
A=0D0
ELSE
A=ATAN2(Y,X)
END IF
IF (A.LT.0D0) A=A+D2PI
AZ=A
EL=ATAN2(Z,R)
END

180
slalib/deuler.f Normal file
View File

@ -0,0 +1,180 @@
SUBROUTINE sla_DEULER (ORDER, PHI, THETA, PSI, RMAT)
*+
* - - - - - - -
* D E U L E R
* - - - - - - -
*
* Form a rotation matrix from the Euler angles - three successive
* rotations about specified Cartesian axes (double precision)
*
* Given:
* ORDER c*(*) specifies about which axes the rotations occur
* PHI d 1st rotation (radians)
* THETA d 2nd rotation ( " )
* PSI d 3rd rotation ( " )
*
* Returned:
* RMAT d(3,3) rotation matrix
*
* A rotation is positive when the reference frame rotates
* anticlockwise as seen looking towards the origin from the
* positive region of the specified axis.
*
* The characters of ORDER define which axes the three successive
* rotations are about. A typical value is 'ZXZ', indicating that
* RMAT is to become the direction cosine matrix corresponding to
* rotations of the reference frame through PHI radians about the
* old Z-axis, followed by THETA radians about the resulting X-axis,
* then PSI radians about the resulting Z-axis.
*
* The axis names can be any of the following, in any order or
* combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal
* axis labelling/numbering conventions apply; the xyz (=123)
* triad is right-handed. Thus, the 'ZXZ' example given above
* could be written 'zxz' or '313' (or even 'ZxZ' or '3xZ'). ORDER
* is terminated by length or by the first unrecognized character.
*
* Fewer than three rotations are acceptable, in which case the later
* angle arguments are ignored. If all rotations are zero, the
* identity matrix is produced.
*
* P.T.Wallace Starlink 23 May 1997
*
* Copyright (C) 1997 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
CHARACTER*(*) ORDER
DOUBLE PRECISION PHI,THETA,PSI,RMAT(3,3)
INTEGER J,I,L,N,K
DOUBLE PRECISION RESULT(3,3),ROTN(3,3),ANGLE,S,C,W,WM(3,3)
CHARACTER AXIS
* Initialize result matrix
DO J=1,3
DO I=1,3
IF (I.NE.J) THEN
RESULT(I,J) = 0D0
ELSE
RESULT(I,J) = 1D0
END IF
END DO
END DO
* Establish length of axis string
L = LEN(ORDER)
* Look at each character of axis string until finished
DO N=1,3
IF (N.LE.L) THEN
* Initialize rotation matrix for the current rotation
DO J=1,3
DO I=1,3
IF (I.NE.J) THEN
ROTN(I,J) = 0D0
ELSE
ROTN(I,J) = 1D0
END IF
END DO
END DO
* Pick up the appropriate Euler angle and take sine & cosine
IF (N.EQ.1) THEN
ANGLE = PHI
ELSE IF (N.EQ.2) THEN
ANGLE = THETA
ELSE
ANGLE = PSI
END IF
S = SIN(ANGLE)
C = COS(ANGLE)
* Identify the axis
AXIS = ORDER(N:N)
IF (AXIS.EQ.'X'.OR.
: AXIS.EQ.'x'.OR.
: AXIS.EQ.'1') THEN
* Matrix for x-rotation
ROTN(2,2) = C
ROTN(2,3) = S
ROTN(3,2) = -S
ROTN(3,3) = C
ELSE IF (AXIS.EQ.'Y'.OR.
: AXIS.EQ.'y'.OR.
: AXIS.EQ.'2') THEN
* Matrix for y-rotation
ROTN(1,1) = C
ROTN(1,3) = -S
ROTN(3,1) = S
ROTN(3,3) = C
ELSE IF (AXIS.EQ.'Z'.OR.
: AXIS.EQ.'z'.OR.
: AXIS.EQ.'3') THEN
* Matrix for z-rotation
ROTN(1,1) = C
ROTN(1,2) = S
ROTN(2,1) = -S
ROTN(2,2) = C
ELSE
* Unrecognized character - fake end of string
L = 0
END IF
* Apply the current rotation (matrix ROTN x matrix RESULT)
DO I=1,3
DO J=1,3
W = 0D0
DO K=1,3
W = W+ROTN(I,K)*RESULT(K,J)
END DO
WM(I,J) = W
END DO
END DO
DO J=1,3
DO I=1,3
RESULT(I,J) = WM(I,J)
END DO
END DO
END IF
END DO
* Copy the result
DO J=1,3
DO I=1,3
RMAT(I,J) = RESULT(I,J)
END DO
END DO
END

297
slalib/dfltin.f Normal file
View File

@ -0,0 +1,297 @@
SUBROUTINE sla_DFLTIN (STRING, NSTRT, DRESLT, JFLAG)
*+
* - - - - - - -
* D F L T I N
* - - - - - - -
*
* Convert free-format input into double precision floating point
*
* Given:
* STRING c string containing number to be decoded
* NSTRT i pointer to where decoding is to start
* DRESLT d current value of result
*
* Returned:
* NSTRT i advanced to next number
* DRESLT d result
* JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error
*
* Notes:
*
* 1 The reason DFLTIN has separate OK status values for +
* and - is to enable minus zero to be detected. This is
* of crucial importance when decoding mixed-radix numbers.
* For example, an angle expressed as deg, arcmin, arcsec
* may have a leading minus sign but a zero degrees field.
*
* 2 A TAB is interpreted as a space, and lowercase characters
* are interpreted as uppercase.
*
* 3 The basic format is the sequence of fields #^.^@#^, where
* # is a sign character + or -, ^ means a string of decimal
* digits, and @, which indicates an exponent, means D or E.
* Various combinations of these fields can be omitted, and
* embedded blanks are permissible in certain places.
*
* 4 Spaces:
*
* . Leading spaces are ignored.
*
* . Embedded spaces are allowed only after +, -, D or E,
* and after the decomal point if the first sequence of
* digits is absent.
*
* . Trailing spaces are ignored; the first signifies
* end of decoding and subsequent ones are skipped.
*
* 5 Delimiters:
*
* . Any character other than +,-,0-9,.,D,E or space may be
* used to signal the end of the number and terminate
* decoding.
*
* . Comma is recognized by DFLTIN as a special case; it
* is skipped, leaving the pointer on the next character.
* See 13, below.
*
* 6 Both signs are optional. The default is +.
*
* 7 The mantissa ^.^ defaults to 1.
*
* 8 The exponent @#^ defaults to D0.
*
* 9 The strings of decimal digits may be of any length.
*
* 10 The decimal point is optional for whole numbers.
*
* 11 A "null result" occurs when the string of characters being
* decoded does not begin with +,-,0-9,.,D or E, or consists
* entirely of spaces. When this condition is detected, JFLAG
* is set to 1 and DRESLT is left untouched.
*
* 12 NSTRT = 1 for the first character in the string.
*
* 13 On return from DFLTIN, NSTRT is set ready for the next
* decode - following trailing blanks and any comma. If a
* delimiter other than comma is being used, NSTRT must be
* incremented before the next call to DFLTIN, otherwise
* all subsequent calls will return a null result.
*
* 14 Errors (JFLAG=2) occur when:
*
* . a +, -, D or E is left unsatisfied; or
*
* . the decimal point is present without at least
* one decimal digit before or after it; or
*
* . an exponent more than 100 has been presented.
*
* 15 When an error has been detected, NSTRT is left
* pointing to the character following the last
* one used before the error came to light. This
* may be after the point at which a more sophisticated
* program could have detected the error. For example,
* DFLTIN does not detect that '1D999' is unacceptable
* (on a computer where this is so) until the entire number
* has been decoded.
*
* 16 Certain highly unlikely combinations of mantissa &
* exponent can cause arithmetic faults during the
* decode, in some cases despite the fact that they
* together could be construed as a valid number.
*
* 17 Decoding is left to right, one pass.
*
* 18 See also FLOTIN and INTIN
*
* Called: sla__IDCHF
*
* P.T.Wallace Starlink 18 March 1999
*
* Copyright (C) 1999 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
CHARACTER*(*) STRING
INTEGER NSTRT
DOUBLE PRECISION DRESLT
INTEGER JFLAG
INTEGER NPTR,MSIGN,NEXP,NDP,NVEC,NDIGIT,ISIGNX,J
DOUBLE PRECISION DMANT,DIGIT
* Current character
NPTR=NSTRT
* Set defaults: mantissa & sign, exponent & sign, decimal place count
DMANT=0D0
MSIGN=1
NEXP=0
ISIGNX=1
NDP=0
* Look for sign
100 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 400, 100, 800, 500, 300, 200, 9110, 9100, 9110),NVEC
* 0-9 SP D/E . + - , ELSE END
* Negative
200 CONTINUE
MSIGN=-1
* Look for first leading decimal
300 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 400, 300, 800, 500, 9200, 9200, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Accept leading decimals
400 CONTINUE
DMANT=DMANT*1D1+DIGIT
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 400, 1310, 900, 600, 1300, 1300, 1300, 1300, 1310),NVEC
* 0-9 SP D/E . + - , ELSE END
* Look for decimal when none preceded the point
500 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 700, 500, 9200, 9200, 9200, 9200, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Look for trailing decimals
600 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO ( 700, 1310, 900, 1300, 1300, 1300, 1300, 1300, 1310),NVEC
* 0-9 SP D/E . + - , ELSE END
* Accept trailing decimals
700 CONTINUE
NDP=NDP+1
DMANT=DMANT*1D1+DIGIT
GO TO 600
* Exponent symbol first in field: default mantissa to 1
800 CONTINUE
DMANT=1D0
* Look for sign of exponent
900 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1200, 900, 9200, 9200, 1100, 1000, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Exponent negative
1000 CONTINUE
ISIGNX=-1
* Look for first digit of exponent
1100 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1200, 1100, 9200, 9200, 9200, 9200, 9200, 9200, 9210),NVEC
* 0-9 SP D/E . + - , ELSE END
* Use exponent digit
1200 CONTINUE
NEXP=NEXP*10+NDIGIT
IF (NEXP.GT.100) GO TO 9200
* Look for subsequent digits of exponent
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1200, 1310, 1300, 1300, 1300, 1300, 1300, 1300, 1310),NVEC
* 0-9 SP D/E . + - , ELSE END
* Combine exponent and decimal place count
1300 CONTINUE
NPTR=NPTR-1
1310 CONTINUE
NEXP=NEXP*ISIGNX-NDP
* Skip if net exponent negative
IF (NEXP.LT.0) GO TO 1500
* Positive exponent: scale up
1400 CONTINUE
IF (NEXP.LT.10) GO TO 1410
DMANT=DMANT*1D10
NEXP=NEXP-10
GO TO 1400
1410 CONTINUE
IF (NEXP.LT.1) GO TO 1600
DMANT=DMANT*1D1
NEXP=NEXP-1
GO TO 1410
* Negative exponent: scale down
1500 CONTINUE
IF (NEXP.GT.-10) GO TO 1510
DMANT=DMANT/1D10
NEXP=NEXP+10
GO TO 1500
1510 CONTINUE
IF (NEXP.GT.-1) GO TO 1600
DMANT=DMANT/1D1
NEXP=NEXP+1
GO TO 1510
* Get result & status
1600 CONTINUE
J=0
IF (MSIGN.EQ.1) GO TO 1610
J=-1
DMANT=-DMANT
1610 CONTINUE
DRESLT=DMANT
* Skip to end of field
1620 CONTINUE
CALL sla__IDCHF(STRING,NPTR,NVEC,NDIGIT,DIGIT)
GO TO (1720, 1620, 1720, 1720, 1720, 1720, 9900, 1720, 9900),NVEC
* 0-9 SP D/E . + - , ELSE END
1720 CONTINUE
NPTR=NPTR-1
GO TO 9900
* Exits
* Null field
9100 CONTINUE
NPTR=NPTR-1
9110 CONTINUE
J=1
GO TO 9900
* Errors
9200 CONTINUE
NPTR=NPTR-1
9210 CONTINUE
J=2
* Return
9900 CONTINUE
NSTRT=NPTR
JFLAG=J
END

100
slalib/dh2e.f Normal file
View File

@ -0,0 +1,100 @@
SUBROUTINE sla_DH2E (AZ, EL, PHI, HA, DEC)
*+
* - - - - -
* D E 2 H
* - - - - -
*
* Horizon to equatorial coordinates: Az,El to HA,Dec
*
* (double precision)
*
* Given:
* AZ d azimuth
* EL d elevation
* PHI d observatory latitude
*
* Returned:
* HA d hour angle
* DEC d declination
*
* Notes:
*
* 1) All the arguments are angles in radians.
*
* 2) The sign convention for azimuth is north zero, east +pi/2.
*
* 3) HA is returned in the range +/-pi. Declination is returned
* in the range +/-pi/2.
*
* 4) The latitude is (in principle) geodetic. In critical
* applications, corrections for polar motion should be applied.
*
* 5) In some applications it will be important to specify the
* correct type of elevation in order to produce the required
* type of HA,Dec. In particular, it may be important to
* distinguish between the elevation as affected by refraction,
* which will yield the "observed" HA,Dec, and the elevation
* in vacuo, which will yield the "topocentric" HA,Dec. If the
* effects of diurnal aberration can be neglected, the
* topocentric HA,Dec may be used as an approximation to the
* "apparent" HA,Dec.
*
* 6) No range checking of arguments is done.
*
* 7) In applications which involve many such calculations, rather
* than calling the present routine it will be more efficient to
* use inline code, having previously computed fixed terms such
* as sine and cosine of latitude.
*
* P.T.Wallace Starlink 21 February 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION AZ,EL,PHI,HA,DEC
DOUBLE PRECISION SA,CA,SE,CE,SP,CP,X,Y,Z,R
* Useful trig functions
SA=SIN(AZ)
CA=COS(AZ)
SE=SIN(EL)
CE=COS(EL)
SP=SIN(PHI)
CP=COS(PHI)
* HA,Dec as x,y,z
X=-CA*CE*SP+SE*CP
Y=-SA*CE
Z=CA*CE*CP+SE*SP
* To HA,Dec
R=SQRT(X*X+Y*Y)
IF (R.EQ.0D0) THEN
HA=0D0
ELSE
HA=ATAN2(Y,X)
END IF
DEC=ATAN2(Z,R)
END

68
slalib/dimxv.f Normal file
View File

@ -0,0 +1,68 @@
SUBROUTINE sla_DIMXV (DM, VA, VB)
*+
* - - - - - -
* D I M X V
* - - - - - -
*
* Performs the 3-D backward unitary transformation:
*
* vector VB = (inverse of matrix DM) * vector VA
*
* (double precision)
*
* (n.b. the matrix must be unitary, as this routine assumes that
* the inverse and transpose are identical)
*
* Given:
* DM dp(3,3) matrix
* VA dp(3) vector
*
* Returned:
* VB dp(3) result vector
*
* P.T.Wallace Starlink March 1986
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DM(3,3),VA(3),VB(3)
INTEGER I,J
DOUBLE PRECISION W,VW(3)
* Inverse of matrix DM * vector VA -> vector VW
DO J=1,3
W=0D0
DO I=1,3
W=W+DM(I,J)*VA(I)
END DO
VW(J)=W
END DO
* Vector VW -> vector VB
DO J=1,3
VB(J)=VW(J)
END DO
END

92
slalib/djcal.f Normal file
View File

@ -0,0 +1,92 @@
SUBROUTINE sla_DJCAL (NDP, DJM, IYMDF, J)
*+
* - - - - - -
* D J C A L
* - - - - - -
*
* Modified Julian Date to Gregorian Calendar, expressed
* in a form convenient for formatting messages (namely
* rounded to a specified precision, and with the fields
* stored in a single array)
*
* Given:
* NDP i number of decimal places of days in fraction
* DJM d modified Julian Date (JD-2400000.5)
*
* Returned:
* IYMDF i(4) year, month, day, fraction in Gregorian
* calendar
* J i status: nonzero = out of range
*
* Any date after 4701BC March 1 is accepted.
*
* NDP should be 4 or less if internal overflows are to be avoided
* on machines which use 32-bit integers.
*
* The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55).
*
* Last revision: 22 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NDP
DOUBLE PRECISION DJM
INTEGER IYMDF(4),J
INTEGER NFD
DOUBLE PRECISION FD,DF,F,D
INTEGER JD,N4,ND10
* Validate.
IF ( DJM.LE.-2395520D0 .OR. DJM.GE.1D9 ) THEN
J = -1
ELSE
J = 0
* Denominator of fraction.
NFD = 10**MAX(NDP,0)
FD = DBLE(NFD)
* Round date and express in units of fraction.
DF = ANINT(DJM*FD)
* Separate day and fraction.
F = MOD(DF,FD)
IF (F.LT.0D0) F = F+FD
D = (DF-F)/FD
* Express day in Gregorian calendar.
JD = NINT(D)+2400001
N4 = 4*(JD+((2*((4*JD-17918)/146097)*3)/4+1)/2-37)
ND10 = 10*(MOD(N4-237,1461)/4)+5
IYMDF(1) = N4/1461-4712
IYMDF(2) = MOD(ND10/306+2,12)+1
IYMDF(3) = MOD(ND10,306)/10+1
IYMDF(4) = NINT(F)
END IF
END

83
slalib/djcl.f Normal file
View File

@ -0,0 +1,83 @@
SUBROUTINE sla_DJCL (DJM, IY, IM, ID, FD, J)
*+
* - - - - -
* D J C L
* - - - - -
*
* Modified Julian Date to Gregorian year, month, day,
* and fraction of a day.
*
* Given:
* DJM dp modified Julian Date (JD-2400000.5)
*
* Returned:
* IY int year
* IM int month
* ID int day
* FD dp fraction of day
* J int status:
* 0 = OK
* -1 = unacceptable date (before 4701BC March 1)
*
* The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55).
*
* Last revision: 22 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DJM
INTEGER IY,IM,ID
DOUBLE PRECISION FD
INTEGER J
DOUBLE PRECISION F,D
INTEGER JD,N4,ND10
* Check if date is acceptable.
IF ( DJM.LE.-2395520D0 .OR. DJM.GE.1D9 ) THEN
J = -1
ELSE
J = 0
* Separate day and fraction.
F = MOD(DJM,1D0)
IF (F.LT.0D0) F = F+1D0
D = ANINT(DJM-F)
* Express day in Gregorian calendar.
JD = NINT(D)+2400001
N4 = 4*(JD+((6*((4*JD-17918)/146097))/4+1)/2-37)
ND10 = 10*(MOD(N4-237,1461)/4)+5
IY = N4/1461-4712
IM = MOD(ND10/306+2,12)+1
ID = MOD(ND10,306)/10+1
FD = F
J=0
END IF
END

74
slalib/dm2av.f Normal file
View File

@ -0,0 +1,74 @@
SUBROUTINE sla_DM2AV (RMAT, AXVEC)
*+
* - - - - - -
* D M 2 A V
* - - - - - -
*
* From a rotation matrix, determine the corresponding axial vector.
* (double precision)
*
* A rotation matrix describes a rotation about some arbitrary axis,
* called the Euler axis. The "axial vector" returned by this routine
* has the same direction as the Euler axis, and its magnitude is the
* amount of rotation in radians. (The magnitude and direction can be
* separated by means of the routine sla_DVN.)
*
* Given:
* RMAT d(3,3) rotation matrix
*
* Returned:
* AXVEC d(3) axial vector (radians)
*
* The reference frame rotates clockwise as seen looking along
* the axial vector from the origin.
*
* If RMAT is null, so is the result.
*
* Last revision: 26 November 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RMAT(3,3),AXVEC(3)
DOUBLE PRECISION X,Y,Z,S2,C2,PHI,F
X = RMAT(2,3)-RMAT(3,2)
Y = RMAT(3,1)-RMAT(1,3)
Z = RMAT(1,2)-RMAT(2,1)
S2 = SQRT(X*X+Y*Y+Z*Z)
IF (S2.NE.0D0) THEN
C2 = RMAT(1,1)+RMAT(2,2)+RMAT(3,3)-1D0
PHI = ATAN2(S2,C2)
F = PHI/S2
AXVEC(1) = X*F
AXVEC(2) = Y*F
AXVEC(3) = Z*F
ELSE
AXVEC(1) = 0D0
AXVEC(2) = 0D0
AXVEC(3) = 0D0
END IF
END

157
slalib/dmat.f Normal file
View File

@ -0,0 +1,157 @@
SUBROUTINE sla_DMAT (N, A, Y, D, JF, IW)
*+
* - - - - -
* D M A T
* - - - - -
*
* Matrix inversion & solution of simultaneous equations
* (double precision)
*
* For the set of n simultaneous equations in n unknowns:
* A.Y = X
*
* where:
* A is a non-singular N x N matrix
* Y is the vector of N unknowns
* X is the known vector
*
* DMATRX computes:
* the inverse of matrix A
* the determinant of matrix A
* the vector of N unknowns
*
* Arguments:
*
* symbol type dimension before after
*
* N i no. of unknowns unchanged
* A d (N,N) matrix inverse
* Y d (N) known vector solution vector
* D d - determinant
* * JF i - singularity flag
* IW i (N) - workspace
*
* * JF is the singularity flag. If the matrix is non-singular, JF=0
* is returned. If the matrix is singular, JF=-1 & D=0D0 are
* returned. In the latter case, the contents of array A on return
* are undefined.
*
* Algorithm:
* Gaussian elimination with partial pivoting.
*
* Speed:
* Very fast.
*
* Accuracy:
* Fairly accurate - errors 1 to 4 times those of routines optimized
* for accuracy.
*
* P.T.Wallace Starlink 4 December 2001
*
* Copyright (C) 2001 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER N
DOUBLE PRECISION A(N,N),Y(N),D
INTEGER JF
INTEGER IW(N)
DOUBLE PRECISION SFA
PARAMETER (SFA=1D-20)
INTEGER K,IMX,I,J,NP1MK,KI
DOUBLE PRECISION AMX,T,AKK,YK,AIK
JF=0
D=1D0
DO K=1,N
AMX=DABS(A(K,K))
IMX=K
IF (K.NE.N) THEN
DO I=K+1,N
T=DABS(A(I,K))
IF (T.GT.AMX) THEN
AMX=T
IMX=I
END IF
END DO
END IF
IF (AMX.LT.SFA) THEN
JF=-1
ELSE
IF (IMX.NE.K) THEN
DO J=1,N
T=A(K,J)
A(K,J)=A(IMX,J)
A(IMX,J)=T
END DO
T=Y(K)
Y(K)=Y(IMX)
Y(IMX)=T
D=-D
END IF
IW(K)=IMX
AKK=A(K,K)
D=D*AKK
IF (DABS(D).LT.SFA) THEN
JF=-1
ELSE
AKK=1D0/AKK
A(K,K)=AKK
DO J=1,N
IF (J.NE.K) A(K,J)=A(K,J)*AKK
END DO
YK=Y(K)*AKK
Y(K)=YK
DO I=1,N
AIK=A(I,K)
IF (I.NE.K) THEN
DO J=1,N
IF (J.NE.K) A(I,J)=A(I,J)-AIK*A(K,J)
END DO
Y(I)=Y(I)-AIK*YK
END IF
END DO
DO I=1,N
IF (I.NE.K) A(I,K)=-A(I,K)*AKK
END DO
END IF
END IF
END DO
IF (JF.NE.0) THEN
D=0D0
ELSE
DO K=1,N
NP1MK=N+1-K
KI=IW(NP1MK)
IF (NP1MK.NE.KI) THEN
DO I=1,N
T=A(I,NP1MK)
A(I,NP1MK)=A(I,KI)
A(I,KI)=T
END DO
END IF
END DO
END IF
END

658
slalib/dmoon.f Normal file
View File

@ -0,0 +1,658 @@
SUBROUTINE sla_DMOON (DATE, PV)
*+
* - - - - - -
* D M O O N
* - - - - - -
*
* Approximate geocentric position and velocity of the Moon
* (double precision)
*
* Given:
* DATE D TDB (loosely ET) as a Modified Julian Date
* (JD-2400000.5)
*
* Returned:
* PV D(6) Moon x,y,z,xdot,ydot,zdot, mean equator and
* equinox of date (AU, AU/s)
*
* Notes:
*
* 1 This routine is a full implementation of the algorithm
* published by Meeus (see reference).
*
* 2 Meeus quotes accuracies of 10 arcsec in longitude, 3 arcsec in
* latitude and 0.2 arcsec in HP (equivalent to about 20 km in
* distance). Comparison with JPL DE200 over the interval
* 1960-2025 gives RMS errors of 3.7 arcsec and 83 mas/hour in
* longitude, 2.3 arcsec and 48 mas/hour in latitude, 11 km
* and 81 mm/s in distance. The maximum errors over the same
* interval are 18 arcsec and 0.50 arcsec/hour in longitude,
* 11 arcsec and 0.24 arcsec/hour in latitude, 40 km and 0.29 m/s
* in distance.
*
* 3 The original algorithm is expressed in terms of the obsolete
* timescale Ephemeris Time. Either TDB or TT can be used, but
* not UT without incurring significant errors (30 arcsec at
* the present time) due to the Moon's 0.5 arcsec/sec movement.
*
* 4 The algorithm is based on pre IAU 1976 standards. However,
* the result has been moved onto the new (FK5) equinox, an
* adjustment which is in any case much smaller than the
* intrinsic accuracy of the procedure.
*
* 5 Velocity is obtained by a complete analytical differentiation
* of the Meeus model.
*
* Reference:
* Meeus, l'Astronomie, June 1984, p348.
*
* P.T.Wallace Starlink 22 January 1998
*
* Copyright (C) 1998 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DATE,PV(6)
* Degrees, arcseconds and seconds of time to radians
DOUBLE PRECISION D2R,DAS2R,DS2R
PARAMETER (D2R=0.0174532925199432957692369D0,
: DAS2R=4.848136811095359935899141D-6,
: DS2R=7.272205216643039903848712D-5)
* Seconds per Julian century (86400*36525)
DOUBLE PRECISION CJ
PARAMETER (CJ=3155760000D0)
* Julian epoch of B1950
DOUBLE PRECISION B1950
PARAMETER (B1950=1949.9997904423D0)
* Earth equatorial radius in AU ( = 6378.137 / 149597870 )
DOUBLE PRECISION ERADAU
PARAMETER (ERADAU=4.2635212653763D-5)
DOUBLE PRECISION T,THETA,SINOM,COSOM,DOMCOM,WA,DWA,WB,DWB,WOM,
: DWOM,SINWOM,COSWOM,V,DV,COEFF,EMN,EMPN,DN,FN,EN,
: DEN,DTHETA,FTHETA,EL,DEL,B,DB,BF,DBF,P,DP,SP,R,
: DR,X,Y,Z,XD,YD,ZD,SEL,CEL,SB,CB,RCB,RBD,W,EPJ,
: EQCOR,EPS,SINEPS,COSEPS,ES,EC
INTEGER N,I
*
* Coefficients for fundamental arguments
*
* at J1900: T**0, T**1, T**2, T**3
* at epoch: T**0, T**1
*
* Units are degrees for position and Julian centuries for time
*
* Moon's mean longitude
DOUBLE PRECISION ELP0,ELP1,ELP2,ELP3,ELP,DELP
PARAMETER (ELP0=270.434164D0,
: ELP1=481267.8831D0,
: ELP2=-0.001133D0,
: ELP3=0.0000019D0)
* Sun's mean anomaly
DOUBLE PRECISION EM0,EM1,EM2,EM3,EM,DEM
PARAMETER (EM0=358.475833D0,
: EM1=35999.0498D0,
: EM2=-0.000150D0,
: EM3=-0.0000033D0)
* Moon's mean anomaly
DOUBLE PRECISION EMP0,EMP1,EMP2,EMP3,EMP,DEMP
PARAMETER (EMP0=296.104608D0,
: EMP1=477198.8491D0,
: EMP2=0.009192D0,
: EMP3=0.0000144D0)
* Moon's mean elongation
DOUBLE PRECISION D0,D1,D2,D3,D,DD
PARAMETER (D0=350.737486D0,
: D1=445267.1142D0,
: D2=-0.001436D0,
: D3=0.0000019D0)
* Mean distance of the Moon from its ascending node
DOUBLE PRECISION F0,F1,F2,F3,F,DF
PARAMETER (F0=11.250889D0,
: F1=483202.0251D0,
: F2=-0.003211D0,
: F3=-0.0000003D0)
* Longitude of the Moon's ascending node
DOUBLE PRECISION OM0,OM1,OM2,OM3,OM,DOM
PARAMETER (OM0=259.183275D0,
: OM1=-1934.1420D0,
: OM2=0.002078D0,
: OM3=0.0000022D0)
* Coefficients for (dimensionless) E factor
DOUBLE PRECISION E1,E2,E,DE,ESQ,DESQ
PARAMETER (E1=-0.002495D0,E2=-0.00000752D0)
* Coefficients for periodic variations etc
DOUBLE PRECISION PAC,PA0,PA1
PARAMETER (PAC=0.000233D0,PA0=51.2D0,PA1=20.2D0)
DOUBLE PRECISION PBC
PARAMETER (PBC=-0.001778D0)
DOUBLE PRECISION PCC
PARAMETER (PCC=0.000817D0)
DOUBLE PRECISION PDC
PARAMETER (PDC=0.002011D0)
DOUBLE PRECISION PEC,PE0,PE1,PE2
PARAMETER (PEC=0.003964D0,
: PE0=346.560D0,PE1=132.870D0,PE2=-0.0091731D0)
DOUBLE PRECISION PFC
PARAMETER (PFC=0.001964D0)
DOUBLE PRECISION PGC
PARAMETER (PGC=0.002541D0)
DOUBLE PRECISION PHC
PARAMETER (PHC=0.001964D0)
DOUBLE PRECISION PIC
PARAMETER (PIC=-0.024691D0)
DOUBLE PRECISION PJC,PJ0,PJ1
PARAMETER (PJC=-0.004328D0,PJ0=275.05D0,PJ1=-2.30D0)
DOUBLE PRECISION CW1
PARAMETER (CW1=0.0004664D0)
DOUBLE PRECISION CW2
PARAMETER (CW2=0.0000754D0)
*
* Coefficients for Moon position
*
* Tx(N) = coefficient of L, B or P term (deg)
* ITx(N,1-5) = coefficients of M, M', D, F, E**n in argument
*
INTEGER NL,NB,NP
PARAMETER (NL=50,NB=45,NP=31)
DOUBLE PRECISION TL(NL),TB(NB),TP(NP)
INTEGER ITL(5,NL),ITB(5,NB),ITP(5,NP)
*
* Longitude
* M M' D F n
DATA TL( 1)/ +6.288750D0 /,
: (ITL(I, 1),I=1,5)/ +0, +1, +0, +0, 0 /
DATA TL( 2)/ +1.274018D0 /,
: (ITL(I, 2),I=1,5)/ +0, -1, +2, +0, 0 /
DATA TL( 3)/ +0.658309D0 /,
: (ITL(I, 3),I=1,5)/ +0, +0, +2, +0, 0 /
DATA TL( 4)/ +0.213616D0 /,
: (ITL(I, 4),I=1,5)/ +0, +2, +0, +0, 0 /
DATA TL( 5)/ -0.185596D0 /,
: (ITL(I, 5),I=1,5)/ +1, +0, +0, +0, 1 /
DATA TL( 6)/ -0.114336D0 /,
: (ITL(I, 6),I=1,5)/ +0, +0, +0, +2, 0 /
DATA TL( 7)/ +0.058793D0 /,
: (ITL(I, 7),I=1,5)/ +0, -2, +2, +0, 0 /
DATA TL( 8)/ +0.057212D0 /,
: (ITL(I, 8),I=1,5)/ -1, -1, +2, +0, 1 /
DATA TL( 9)/ +0.053320D0 /,
: (ITL(I, 9),I=1,5)/ +0, +1, +2, +0, 0 /
DATA TL(10)/ +0.045874D0 /,
: (ITL(I,10),I=1,5)/ -1, +0, +2, +0, 1 /
DATA TL(11)/ +0.041024D0 /,
: (ITL(I,11),I=1,5)/ -1, +1, +0, +0, 1 /
DATA TL(12)/ -0.034718D0 /,
: (ITL(I,12),I=1,5)/ +0, +0, +1, +0, 0 /
DATA TL(13)/ -0.030465D0 /,
: (ITL(I,13),I=1,5)/ +1, +1, +0, +0, 1 /
DATA TL(14)/ +0.015326D0 /,
: (ITL(I,14),I=1,5)/ +0, +0, +2, -2, 0 /
DATA TL(15)/ -0.012528D0 /,
: (ITL(I,15),I=1,5)/ +0, +1, +0, +2, 0 /
DATA TL(16)/ -0.010980D0 /,
: (ITL(I,16),I=1,5)/ +0, -1, +0, +2, 0 /
DATA TL(17)/ +0.010674D0 /,
: (ITL(I,17),I=1,5)/ +0, -1, +4, +0, 0 /
DATA TL(18)/ +0.010034D0 /,
: (ITL(I,18),I=1,5)/ +0, +3, +0, +0, 0 /
DATA TL(19)/ +0.008548D0 /,
: (ITL(I,19),I=1,5)/ +0, -2, +4, +0, 0 /
DATA TL(20)/ -0.007910D0 /,
: (ITL(I,20),I=1,5)/ +1, -1, +2, +0, 1 /
DATA TL(21)/ -0.006783D0 /,
: (ITL(I,21),I=1,5)/ +1, +0, +2, +0, 1 /
DATA TL(22)/ +0.005162D0 /,
: (ITL(I,22),I=1,5)/ +0, +1, -1, +0, 0 /
DATA TL(23)/ +0.005000D0 /,
: (ITL(I,23),I=1,5)/ +1, +0, +1, +0, 1 /
DATA TL(24)/ +0.004049D0 /,
: (ITL(I,24),I=1,5)/ -1, +1, +2, +0, 1 /
DATA TL(25)/ +0.003996D0 /,
: (ITL(I,25),I=1,5)/ +0, +2, +2, +0, 0 /
DATA TL(26)/ +0.003862D0 /,
: (ITL(I,26),I=1,5)/ +0, +0, +4, +0, 0 /
DATA TL(27)/ +0.003665D0 /,
: (ITL(I,27),I=1,5)/ +0, -3, +2, +0, 0 /
DATA TL(28)/ +0.002695D0 /,
: (ITL(I,28),I=1,5)/ -1, +2, +0, +0, 1 /
DATA TL(29)/ +0.002602D0 /,
: (ITL(I,29),I=1,5)/ +0, +1, -2, -2, 0 /
DATA TL(30)/ +0.002396D0 /,
: (ITL(I,30),I=1,5)/ -1, -2, +2, +0, 1 /
DATA TL(31)/ -0.002349D0 /,
: (ITL(I,31),I=1,5)/ +0, +1, +1, +0, 0 /
DATA TL(32)/ +0.002249D0 /,
: (ITL(I,32),I=1,5)/ -2, +0, +2, +0, 2 /
DATA TL(33)/ -0.002125D0 /,
: (ITL(I,33),I=1,5)/ +1, +2, +0, +0, 1 /
DATA TL(34)/ -0.002079D0 /,
: (ITL(I,34),I=1,5)/ +2, +0, +0, +0, 2 /
DATA TL(35)/ +0.002059D0 /,
: (ITL(I,35),I=1,5)/ -2, -1, +2, +0, 2 /
DATA TL(36)/ -0.001773D0 /,
: (ITL(I,36),I=1,5)/ +0, +1, +2, -2, 0 /
DATA TL(37)/ -0.001595D0 /,
: (ITL(I,37),I=1,5)/ +0, +0, +2, +2, 0 /
DATA TL(38)/ +0.001220D0 /,
: (ITL(I,38),I=1,5)/ -1, -1, +4, +0, 1 /
DATA TL(39)/ -0.001110D0 /,
: (ITL(I,39),I=1,5)/ +0, +2, +0, +2, 0 /
DATA TL(40)/ +0.000892D0 /,
: (ITL(I,40),I=1,5)/ +0, +1, -3, +0, 0 /
DATA TL(41)/ -0.000811D0 /,
: (ITL(I,41),I=1,5)/ +1, +1, +2, +0, 1 /
DATA TL(42)/ +0.000761D0 /,
: (ITL(I,42),I=1,5)/ -1, -2, +4, +0, 1 /
DATA TL(43)/ +0.000717D0 /,
: (ITL(I,43),I=1,5)/ -2, +1, +0, +0, 2 /
DATA TL(44)/ +0.000704D0 /,
: (ITL(I,44),I=1,5)/ -2, +1, -2, +0, 2 /
DATA TL(45)/ +0.000693D0 /,
: (ITL(I,45),I=1,5)/ +1, -2, +2, +0, 1 /
DATA TL(46)/ +0.000598D0 /,
: (ITL(I,46),I=1,5)/ -1, +0, +2, -2, 1 /
DATA TL(47)/ +0.000550D0 /,
: (ITL(I,47),I=1,5)/ +0, +1, +4, +0, 0 /
DATA TL(48)/ +0.000538D0 /,
: (ITL(I,48),I=1,5)/ +0, +4, +0, +0, 0 /
DATA TL(49)/ +0.000521D0 /,
: (ITL(I,49),I=1,5)/ -1, +0, +4, +0, 1 /
DATA TL(50)/ +0.000486D0 /,
: (ITL(I,50),I=1,5)/ +0, +2, -1, +0, 0 /
*
* Latitude
* M M' D F n
DATA TB( 1)/ +5.128189D0 /,
: (ITB(I, 1),I=1,5)/ +0, +0, +0, +1, 0 /
DATA TB( 2)/ +0.280606D0 /,
: (ITB(I, 2),I=1,5)/ +0, +1, +0, +1, 0 /
DATA TB( 3)/ +0.277693D0 /,
: (ITB(I, 3),I=1,5)/ +0, +1, +0, -1, 0 /
DATA TB( 4)/ +0.173238D0 /,
: (ITB(I, 4),I=1,5)/ +0, +0, +2, -1, 0 /
DATA TB( 5)/ +0.055413D0 /,
: (ITB(I, 5),I=1,5)/ +0, -1, +2, +1, 0 /
DATA TB( 6)/ +0.046272D0 /,
: (ITB(I, 6),I=1,5)/ +0, -1, +2, -1, 0 /
DATA TB( 7)/ +0.032573D0 /,
: (ITB(I, 7),I=1,5)/ +0, +0, +2, +1, 0 /
DATA TB( 8)/ +0.017198D0 /,
: (ITB(I, 8),I=1,5)/ +0, +2, +0, +1, 0 /
DATA TB( 9)/ +0.009267D0 /,
: (ITB(I, 9),I=1,5)/ +0, +1, +2, -1, 0 /
DATA TB(10)/ +0.008823D0 /,
: (ITB(I,10),I=1,5)/ +0, +2, +0, -1, 0 /
DATA TB(11)/ +0.008247D0 /,
: (ITB(I,11),I=1,5)/ -1, +0, +2, -1, 1 /
DATA TB(12)/ +0.004323D0 /,
: (ITB(I,12),I=1,5)/ +0, -2, +2, -1, 0 /
DATA TB(13)/ +0.004200D0 /,
: (ITB(I,13),I=1,5)/ +0, +1, +2, +1, 0 /
DATA TB(14)/ +0.003372D0 /,
: (ITB(I,14),I=1,5)/ -1, +0, -2, +1, 1 /
DATA TB(15)/ +0.002472D0 /,
: (ITB(I,15),I=1,5)/ -1, -1, +2, +1, 1 /
DATA TB(16)/ +0.002222D0 /,
: (ITB(I,16),I=1,5)/ -1, +0, +2, +1, 1 /
DATA TB(17)/ +0.002072D0 /,
: (ITB(I,17),I=1,5)/ -1, -1, +2, -1, 1 /
DATA TB(18)/ +0.001877D0 /,
: (ITB(I,18),I=1,5)/ -1, +1, +0, +1, 1 /
DATA TB(19)/ +0.001828D0 /,
: (ITB(I,19),I=1,5)/ +0, -1, +4, -1, 0 /
DATA TB(20)/ -0.001803D0 /,
: (ITB(I,20),I=1,5)/ +1, +0, +0, +1, 1 /
DATA TB(21)/ -0.001750D0 /,
: (ITB(I,21),I=1,5)/ +0, +0, +0, +3, 0 /
DATA TB(22)/ +0.001570D0 /,
: (ITB(I,22),I=1,5)/ -1, +1, +0, -1, 1 /
DATA TB(23)/ -0.001487D0 /,
: (ITB(I,23),I=1,5)/ +0, +0, +1, +1, 0 /
DATA TB(24)/ -0.001481D0 /,
: (ITB(I,24),I=1,5)/ +1, +1, +0, +1, 1 /
DATA TB(25)/ +0.001417D0 /,
: (ITB(I,25),I=1,5)/ -1, -1, +0, +1, 1 /
DATA TB(26)/ +0.001350D0 /,
: (ITB(I,26),I=1,5)/ -1, +0, +0, +1, 1 /
DATA TB(27)/ +0.001330D0 /,
: (ITB(I,27),I=1,5)/ +0, +0, -1, +1, 0 /
DATA TB(28)/ +0.001106D0 /,
: (ITB(I,28),I=1,5)/ +0, +3, +0, +1, 0 /
DATA TB(29)/ +0.001020D0 /,
: (ITB(I,29),I=1,5)/ +0, +0, +4, -1, 0 /
DATA TB(30)/ +0.000833D0 /,
: (ITB(I,30),I=1,5)/ +0, -1, +4, +1, 0 /
DATA TB(31)/ +0.000781D0 /,
: (ITB(I,31),I=1,5)/ +0, +1, +0, -3, 0 /
DATA TB(32)/ +0.000670D0 /,
: (ITB(I,32),I=1,5)/ +0, -2, +4, +1, 0 /
DATA TB(33)/ +0.000606D0 /,
: (ITB(I,33),I=1,5)/ +0, +0, +2, -3, 0 /
DATA TB(34)/ +0.000597D0 /,
: (ITB(I,34),I=1,5)/ +0, +2, +2, -1, 0 /
DATA TB(35)/ +0.000492D0 /,
: (ITB(I,35),I=1,5)/ -1, +1, +2, -1, 1 /
DATA TB(36)/ +0.000450D0 /,
: (ITB(I,36),I=1,5)/ +0, +2, -2, -1, 0 /
DATA TB(37)/ +0.000439D0 /,
: (ITB(I,37),I=1,5)/ +0, +3, +0, -1, 0 /
DATA TB(38)/ +0.000423D0 /,
: (ITB(I,38),I=1,5)/ +0, +2, +2, +1, 0 /
DATA TB(39)/ +0.000422D0 /,
: (ITB(I,39),I=1,5)/ +0, -3, +2, -1, 0 /
DATA TB(40)/ -0.000367D0 /,
: (ITB(I,40),I=1,5)/ +1, -1, +2, +1, 1 /
DATA TB(41)/ -0.000353D0 /,
: (ITB(I,41),I=1,5)/ +1, +0, +2, +1, 1 /
DATA TB(42)/ +0.000331D0 /,
: (ITB(I,42),I=1,5)/ +0, +0, +4, +1, 0 /
DATA TB(43)/ +0.000317D0 /,
: (ITB(I,43),I=1,5)/ -1, +1, +2, +1, 1 /
DATA TB(44)/ +0.000306D0 /,
: (ITB(I,44),I=1,5)/ -2, +0, +2, -1, 2 /
DATA TB(45)/ -0.000283D0 /,
: (ITB(I,45),I=1,5)/ +0, +1, +0, +3, 0 /
*
* Parallax
* M M' D F n
DATA TP( 1)/ +0.950724D0 /,
: (ITP(I, 1),I=1,5)/ +0, +0, +0, +0, 0 /
DATA TP( 2)/ +0.051818D0 /,
: (ITP(I, 2),I=1,5)/ +0, +1, +0, +0, 0 /
DATA TP( 3)/ +0.009531D0 /,
: (ITP(I, 3),I=1,5)/ +0, -1, +2, +0, 0 /
DATA TP( 4)/ +0.007843D0 /,
: (ITP(I, 4),I=1,5)/ +0, +0, +2, +0, 0 /
DATA TP( 5)/ +0.002824D0 /,
: (ITP(I, 5),I=1,5)/ +0, +2, +0, +0, 0 /
DATA TP( 6)/ +0.000857D0 /,
: (ITP(I, 6),I=1,5)/ +0, +1, +2, +0, 0 /
DATA TP( 7)/ +0.000533D0 /,
: (ITP(I, 7),I=1,5)/ -1, +0, +2, +0, 1 /
DATA TP( 8)/ +0.000401D0 /,
: (ITP(I, 8),I=1,5)/ -1, -1, +2, +0, 1 /
DATA TP( 9)/ +0.000320D0 /,
: (ITP(I, 9),I=1,5)/ -1, +1, +0, +0, 1 /
DATA TP(10)/ -0.000271D0 /,
: (ITP(I,10),I=1,5)/ +0, +0, +1, +0, 0 /
DATA TP(11)/ -0.000264D0 /,
: (ITP(I,11),I=1,5)/ +1, +1, +0, +0, 1 /
DATA TP(12)/ -0.000198D0 /,
: (ITP(I,12),I=1,5)/ +0, -1, +0, +2, 0 /
DATA TP(13)/ +0.000173D0 /,
: (ITP(I,13),I=1,5)/ +0, +3, +0, +0, 0 /
DATA TP(14)/ +0.000167D0 /,
: (ITP(I,14),I=1,5)/ +0, -1, +4, +0, 0 /
DATA TP(15)/ -0.000111D0 /,
: (ITP(I,15),I=1,5)/ +1, +0, +0, +0, 1 /
DATA TP(16)/ +0.000103D0 /,
: (ITP(I,16),I=1,5)/ +0, -2, +4, +0, 0 /
DATA TP(17)/ -0.000084D0 /,
: (ITP(I,17),I=1,5)/ +0, +2, -2, +0, 0 /
DATA TP(18)/ -0.000083D0 /,
: (ITP(I,18),I=1,5)/ +1, +0, +2, +0, 1 /
DATA TP(19)/ +0.000079D0 /,
: (ITP(I,19),I=1,5)/ +0, +2, +2, +0, 0 /
DATA TP(20)/ +0.000072D0 /,
: (ITP(I,20),I=1,5)/ +0, +0, +4, +0, 0 /
DATA TP(21)/ +0.000064D0 /,
: (ITP(I,21),I=1,5)/ -1, +1, +2, +0, 1 /
DATA TP(22)/ -0.000063D0 /,
: (ITP(I,22),I=1,5)/ +1, -1, +2, +0, 1 /
DATA TP(23)/ +0.000041D0 /,
: (ITP(I,23),I=1,5)/ +1, +0, +1, +0, 1 /
DATA TP(24)/ +0.000035D0 /,
: (ITP(I,24),I=1,5)/ -1, +2, +0, +0, 1 /
DATA TP(25)/ -0.000033D0 /,
: (ITP(I,25),I=1,5)/ +0, +3, -2, +0, 0 /
DATA TP(26)/ -0.000030D0 /,
: (ITP(I,26),I=1,5)/ +0, +1, +1, +0, 0 /
DATA TP(27)/ -0.000029D0 /,
: (ITP(I,27),I=1,5)/ +0, +0, -2, +2, 0 /
DATA TP(28)/ -0.000029D0 /,
: (ITP(I,28),I=1,5)/ +1, +2, +0, +0, 1 /
DATA TP(29)/ +0.000026D0 /,
: (ITP(I,29),I=1,5)/ -2, +0, +2, +0, 2 /
DATA TP(30)/ -0.000023D0 /,
: (ITP(I,30),I=1,5)/ +0, +1, -2, +2, 0 /
DATA TP(31)/ +0.000019D0 /,
: (ITP(I,31),I=1,5)/ -1, -1, +4, +0, 1 /
* Centuries since J1900
T=(DATE-15019.5D0)/36525D0
*
* Fundamental arguments (radians) and derivatives (radians per
* Julian century) for the current epoch
*
* Moon's mean longitude
ELP=D2R*MOD(ELP0+(ELP1+(ELP2+ELP3*T)*T)*T,360D0)
DELP=D2R*(ELP1+(2D0*ELP2+3D0*ELP3*T)*T)
* Sun's mean anomaly
EM=D2R*MOD(EM0+(EM1+(EM2+EM3*T)*T)*T,360D0)
DEM=D2R*(EM1+(2D0*EM2+3D0*EM3*T)*T)
* Moon's mean anomaly
EMP=D2R*MOD(EMP0+(EMP1+(EMP2+EMP3*T)*T)*T,360D0)
DEMP=D2R*(EMP1+(2D0*EMP2+3D0*EMP3*T)*T)
* Moon's mean elongation
D=D2R*MOD(D0+(D1+(D2+D3*T)*T)*T,360D0)
DD=D2R*(D1+(2D0*D2+3D0*D3*T)*T)
* Mean distance of the Moon from its ascending node
F=D2R*MOD(F0+(F1+(F2+F3*T)*T)*T,360D0)
DF=D2R*(F1+(2D0*F2+3D0*F3*T)*T)
* Longitude of the Moon's ascending node
OM=D2R*MOD(OM0+(OM1+(OM2+OM3*T)*T)*T,360D0)
DOM=D2R*(OM1+(2D0*OM2+3D0*OM3*T)*T)
SINOM=SIN(OM)
COSOM=COS(OM)
DOMCOM=DOM*COSOM
* Add the periodic variations
THETA=D2R*(PA0+PA1*T)
WA=SIN(THETA)
DWA=D2R*PA1*COS(THETA)
THETA=D2R*(PE0+(PE1+PE2*T)*T)
WB=PEC*SIN(THETA)
DWB=D2R*PEC*(PE1+2D0*PE2*T)*COS(THETA)
ELP=ELP+D2R*(PAC*WA+WB+PFC*SINOM)
DELP=DELP+D2R*(PAC*DWA+DWB+PFC*DOMCOM)
EM=EM+D2R*PBC*WA
DEM=DEM+D2R*PBC*DWA
EMP=EMP+D2R*(PCC*WA+WB+PGC*SINOM)
DEMP=DEMP+D2R*(PCC*DWA+DWB+PGC*DOMCOM)
D=D+D2R*(PDC*WA+WB+PHC*SINOM)
DD=DD+D2R*(PDC*DWA+DWB+PHC*DOMCOM)
WOM=OM+D2R*(PJ0+PJ1*T)
DWOM=DOM+D2R*PJ1
SINWOM=SIN(WOM)
COSWOM=COS(WOM)
F=F+D2R*(WB+PIC*SINOM+PJC*SINWOM)
DF=DF+D2R*(DWB+PIC*DOMCOM+PJC*DWOM*COSWOM)
* E-factor, and square
E=1D0+(E1+E2*T)*T
DE=E1+2D0*E2*T
ESQ=E*E
DESQ=2D0*E*DE
*
* Series expansions
*
* Longitude
V=0D0
DV=0D0
DO N=NL,1,-1
COEFF=TL(N)
EMN=DBLE(ITL(1,N))
EMPN=DBLE(ITL(2,N))
DN=DBLE(ITL(3,N))
FN=DBLE(ITL(4,N))
I=ITL(5,N)
IF (I.EQ.0) THEN
EN=1D0
DEN=0D0
ELSE IF (I.EQ.1) THEN
EN=E
DEN=DE
ELSE
EN=ESQ
DEN=DESQ
END IF
THETA=EMN*EM+EMPN*EMP+DN*D+FN*F
DTHETA=EMN*DEM+EMPN*DEMP+DN*DD+FN*DF
FTHETA=SIN(THETA)
V=V+COEFF*FTHETA*EN
DV=DV+COEFF*(COS(THETA)*DTHETA*EN+FTHETA*DEN)
END DO
EL=ELP+D2R*V
DEL=(DELP+D2R*DV)/CJ
* Latitude
V=0D0
DV=0D0
DO N=NB,1,-1
COEFF=TB(N)
EMN=DBLE(ITB(1,N))
EMPN=DBLE(ITB(2,N))
DN=DBLE(ITB(3,N))
FN=DBLE(ITB(4,N))
I=ITB(5,N)
IF (I.EQ.0) THEN
EN=1D0
DEN=0D0
ELSE IF (I.EQ.1) THEN
EN=E
DEN=DE
ELSE
EN=ESQ
DEN=DESQ
END IF
THETA=EMN*EM+EMPN*EMP+DN*D+FN*F
DTHETA=EMN*DEM+EMPN*DEMP+DN*DD+FN*DF
FTHETA=SIN(THETA)
V=V+COEFF*FTHETA*EN
DV=DV+COEFF*(COS(THETA)*DTHETA*EN+FTHETA*DEN)
END DO
BF=1D0-CW1*COSOM-CW2*COSWOM
DBF=CW1*DOM*SINOM+CW2*DWOM*SINWOM
B=D2R*V*BF
DB=D2R*(DV*BF+V*DBF)/CJ
* Parallax
V=0D0
DV=0D0
DO N=NP,1,-1
COEFF=TP(N)
EMN=DBLE(ITP(1,N))
EMPN=DBLE(ITP(2,N))
DN=DBLE(ITP(3,N))
FN=DBLE(ITP(4,N))
I=ITP(5,N)
IF (I.EQ.0) THEN
EN=1D0
DEN=0D0
ELSE IF (I.EQ.1) THEN
EN=E
DEN=DE
ELSE
EN=ESQ
DEN=DESQ
END IF
THETA=EMN*EM+EMPN*EMP+DN*D+FN*F
DTHETA=EMN*DEM+EMPN*DEMP+DN*DD+FN*DF
FTHETA=COS(THETA)
V=V+COEFF*FTHETA*EN
DV=DV+COEFF*(-SIN(THETA)*DTHETA*EN+FTHETA*DEN)
END DO
P=D2R*V
DP=D2R*DV/CJ
*
* Transformation into final form
*
* Parallax to distance (AU, AU/sec)
SP=SIN(P)
R=ERADAU/SP
DR=-R*DP*COS(P)/SP
* Longitude, latitude to x,y,z (AU)
SEL=SIN(EL)
CEL=COS(EL)
SB=SIN(B)
CB=COS(B)
RCB=R*CB
RBD=R*DB
W=RBD*SB-CB*DR
X=RCB*CEL
Y=RCB*SEL
Z=R*SB
XD=-Y*DEL-W*CEL
YD=X*DEL-W*SEL
ZD=RBD*CB+SB*DR
* Julian centuries since J2000
T=(DATE-51544.5D0)/36525D0
* Fricke equinox correction
EPJ=2000D0+T*100D0
EQCOR=DS2R*(0.035D0+0.00085D0*(EPJ-B1950))
* Mean obliquity (IAU 1976)
EPS=DAS2R*(84381.448D0+(-46.8150D0+(-0.00059D0+0.001813D0*T)*T)*T)
* To the equatorial system, mean of date, FK5 system
SINEPS=SIN(EPS)
COSEPS=COS(EPS)
ES=EQCOR*SINEPS
EC=EQCOR*COSEPS
PV(1)=X-EC*Y+ES*Z
PV(2)=EQCOR*X+Y*COSEPS-Z*SINEPS
PV(3)=Y*SINEPS+Z*COSEPS
PV(4)=XD-EC*YD+ES*ZD
PV(5)=EQCOR*XD+YD*COSEPS-ZD*SINEPS
PV(6)=YD*SINEPS+ZD*COSEPS
END

72
slalib/dmxm.f Normal file
View File

@ -0,0 +1,72 @@
SUBROUTINE sla_DMXM (A, B, C)
*+
* - - - - -
* D M X M
* - - - - -
*
* Product of two 3x3 matrices:
*
* matrix C = matrix A x matrix B
*
* (double precision)
*
* Given:
* A dp(3,3) matrix
* B dp(3,3) matrix
*
* Returned:
* C dp(3,3) matrix result
*
* To comply with the ANSI Fortran 77 standard, A, B and C must
* be different arrays. However, the routine is coded so as to
* work properly on many platforms even if this rule is violated.
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION A(3,3),B(3,3),C(3,3)
INTEGER I,J,K
DOUBLE PRECISION W,WM(3,3)
* Multiply into scratch matrix
DO I=1,3
DO J=1,3
W=0D0
DO K=1,3
W=W+A(I,K)*B(K,J)
END DO
WM(I,J)=W
END DO
END DO
* Return the result
DO J=1,3
DO I=1,3
C(I,J)=WM(I,J)
END DO
END DO
END

68
slalib/dmxv.f Normal file
View File

@ -0,0 +1,68 @@
SUBROUTINE sla_DMXV (DM, VA, VB)
*+
* - - - - -
* D M X V
* - - - - -
*
* Performs the 3-D forward unitary transformation:
*
* vector VB = matrix DM * vector VA
*
* (double precision)
*
* Given:
* DM dp(3,3) matrix
* VA dp(3) vector
*
* Returned:
* VB dp(3) result vector
*
* To comply with the ANSI Fortran 77 standard, VA and VB must be
* different arrays. However, the routine is coded so as to work
* properly on many platforms even if this rule is violated.
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DM(3,3),VA(3),VB(3)
INTEGER I,J
DOUBLE PRECISION W,VW(3)
* Matrix DM * vector VA -> vector VW
DO J=1,3
W=0D0
DO I=1,3
W=W+DM(J,I)*VA(I)
END DO
VW(J)=W
END DO
* Vector VW -> vector VB
DO J=1,3
VB(J)=VW(J)
END DO
END

81
slalib/dpav.f Normal file
View File

@ -0,0 +1,81 @@
DOUBLE PRECISION FUNCTION sla_DPAV ( V1, V2 )
*+
* - - - - -
* D P A V
* - - - - -
*
* Position angle of one celestial direction with respect to another.
*
* (double precision)
*
* Given:
* V1 d(3) direction cosines of one point
* V2 d(3) direction cosines of the other point
*
* (The coordinate frames correspond to RA,Dec, Long,Lat etc.)
*
* The result is the bearing (position angle), in radians, of point
* V2 with respect to point V1. It is in the range +/- pi. The
* sense is such that if V2 is a small distance east of V1, the
* bearing is about +pi/2. Zero is returned if the two points
* are coincident.
*
* V1 and V2 need not be unit vectors.
*
* The routine sla_DBEAR performs an equivalent function except
* that the points are specified in the form of spherical
* coordinates.
*
* Last revision: 16 March 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION V1(3),V2(3)
DOUBLE PRECISION X1,Y1,Z1,W,X2,Y2,Z2,SQ,CQ
* The unit vector to point 1.
X1 = V1(1)
Y1 = V1(2)
Z1 = V1(3)
W = SQRT(X1*X1+Y1*Y1+Z1*Z1)
IF (W.NE.0D0) THEN
X1 = X1/W
Y1 = Y1/W
Z1 = Z1/W
END IF
* The vector to point 2.
X2 = V2(1)
Y2 = V2(2)
Z2 = V2(3)
* Position angle.
SQ = Y2*X1-X2*Y1
CQ = Z2*(X1*X1+Y1*Y1)-Z1*(X2*X1+Y2*Y1)
IF (SQ.EQ.0D0.AND.CQ.EQ.0D0) CQ=1D0
sla_DPAV = ATAN2(SQ,CQ)
END

75
slalib/dr2af.f Normal file
View File

@ -0,0 +1,75 @@
SUBROUTINE sla_DR2AF (NDP, ANGLE, SIGN, IDMSF)
*+
* - - - - - -
* D R 2 A F
* - - - - - -
*
* Convert an angle in radians to degrees, arcminutes, arcseconds
* (double precision)
*
* Given:
* NDP i number of decimal places of arcseconds
* ANGLE d angle in radians
*
* Returned:
* SIGN c '+' or '-'
* IDMSF i(4) degrees, arcminutes, arcseconds, fraction
*
* Notes:
*
* 1) NDP less than zero is interpreted as zero.
*
* 2) The largest useful value for NDP is determined by the size
* of ANGLE, the format of DOUBLE PRECISION floating-point
* numbers on the target machine, and the risk of overflowing
* IDMSF(4). On some architectures, for ANGLE up to 2pi, the
* available floating-point precision corresponds roughly to
* NDP=12. However, the practical limit is NDP=9, set by the
* capacity of a typical 32-bit IDMSF(4).
*
* 3) The absolute value of ANGLE may exceed 2pi. In cases where it
* does not, it is up to the caller to test for and handle the
* case where ANGLE is very nearly 2pi and rounds up to 360 deg,
* by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero.
*
* Called: sla_DD2TF
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NDP
DOUBLE PRECISION ANGLE
CHARACTER SIGN*(*)
INTEGER IDMSF(4)
* Hours to degrees * radians to turns
DOUBLE PRECISION F
PARAMETER (F=15D0/6.283185307179586476925287D0)
* Scale then use days to h,m,s routine
CALL sla_DD2TF(NDP,ANGLE*F,SIGN,IDMSF)
END

75
slalib/dr2tf.f Normal file
View File

@ -0,0 +1,75 @@
SUBROUTINE sla_DR2TF (NDP, ANGLE, SIGN, IHMSF)
*+
* - - - - - -
* D R 2 T F
* - - - - - -
*
* Convert an angle in radians to hours, minutes, seconds
* (double precision)
*
* Given:
* NDP i number of decimal places of seconds
* ANGLE d angle in radians
*
* Returned:
* SIGN c '+' or '-'
* IHMSF i(4) hours, minutes, seconds, fraction
*
* Notes:
*
* 1) NDP less than zero is interpreted as zero.
*
* 2) The largest useful value for NDP is determined by the size
* of ANGLE, the format of DOUBLE PRECISION floating-point
* numbers on the target machine, and the risk of overflowing
* IHMSF(4). On some architectures, for ANGLE up to 2pi, the
* available floating-point precision corresponds roughly to
* NDP=12. However, the practical limit is NDP=9, set by the
* capacity of a typical 32-bit IHMSF(4).
*
* 3) The absolute value of ANGLE may exceed 2pi. In cases where it
* does not, it is up to the caller to test for and handle the
* case where ANGLE is very nearly 2pi and rounds up to 24 hours,
* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero.
*
* Called: sla_DD2TF
*
* Last revision: 26 December 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER NDP
DOUBLE PRECISION ANGLE
CHARACTER SIGN*(*)
INTEGER IHMSF(4)
* Turns to radians
DOUBLE PRECISION T2R
PARAMETER (T2R=6.283185307179586476925287D0)
* Scale then use days to h,m,s routine
CALL sla_DD2TF(NDP,ANGLE/T2R,SIGN,IHMSF)
END

49
slalib/drange.f Normal file
View File

@ -0,0 +1,49 @@
DOUBLE PRECISION FUNCTION sla_DRANGE (ANGLE)
*+
* - - - - - - -
* D R A N G E
* - - - - - - -
*
* Normalize angle into range +/- pi (double precision)
*
* Given:
* ANGLE dp the angle in radians
*
* The result (double precision) is ANGLE expressed in the range +/- pi.
*
* P.T.Wallace Starlink 23 November 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION ANGLE
DOUBLE PRECISION DPI,D2PI
PARAMETER (DPI=3.141592653589793238462643D0)
PARAMETER (D2PI=6.283185307179586476925287D0)
sla_DRANGE=MOD(ANGLE,D2PI)
IF (ABS(sla_DRANGE).GE.DPI)
: sla_DRANGE=sla_DRANGE-SIGN(D2PI,ANGLE)
END

47
slalib/dranrm.f Normal file
View File

@ -0,0 +1,47 @@
DOUBLE PRECISION FUNCTION sla_DRANRM (ANGLE)
*+
* - - - - - - -
* D R A N R M
* - - - - - - -
*
* Normalize angle into range 0-2 pi (double precision)
*
* Given:
* ANGLE dp the angle in radians
*
* The result is ANGLE expressed in the range 0-2 pi.
*
* Last revision: 22 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION ANGLE
DOUBLE PRECISION D2PI
PARAMETER (D2PI=6.283185307179586476925286766559D0)
sla_DRANRM = MOD(ANGLE,D2PI)
IF (sla_DRANRM.LT.0D0) sla_DRANRM = sla_DRANRM+D2PI
END

74
slalib/ds2c6.f Normal file
View File

@ -0,0 +1,74 @@
SUBROUTINE sla_DS2C6 (A, B, R, AD, BD, RD, V)
*+
* - - - - - -
* D S 2 C 6
* - - - - - -
*
* Conversion of position & velocity in spherical coordinates
* to Cartesian coordinates
*
* (double precision)
*
* Given:
* A dp longitude (radians)
* B dp latitude (radians)
* R dp radial coordinate
* AD dp longitude derivative (radians per unit time)
* BD dp latitude derivative (radians per unit time)
* RD dp radial derivative
*
* Returned:
* V dp(6) Cartesian position & velocity vector
*
* P.T.Wallace Starlink 10 July 1993
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION A,B,R,AD,BD,RD,V(6)
DOUBLE PRECISION SA,CA,SB,CB,RCB,X,Y,RBD,W
* Useful functions
SA=SIN(A)
CA=COS(A)
SB=SIN(B)
CB=COS(B)
RCB=R*CB
X=RCB*CA
Y=RCB*SA
RBD=R*BD
W=RBD*SB-CB*RD
* Position
V(1)=X
V(2)=Y
V(3)=R*SB
* Velocity
V(4)=-Y*AD-W*CA
V(5)=X*AD-W*SA
V(6)=RBD*CB+SB*RD
END

84
slalib/ds2tp.f Normal file
View File

@ -0,0 +1,84 @@
SUBROUTINE sla_DS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)
*+
* - - - - - -
* D S 2 T P
* - - - - - -
*
* Projection of spherical coordinates onto tangent plane:
* "gnomonic" projection - "standard coordinates" (double precision)
*
* Given:
* RA,DEC dp spherical coordinates of point to be projected
* RAZ,DECZ dp spherical coordinates of tangent point
*
* Returned:
* XI,ETA dp rectangular coordinates on tangent plane
* J int status: 0 = OK, star on tangent plane
* 1 = error, star too far from axis
* 2 = error, antistar on tangent plane
* 3 = error, antistar too far from axis
*
* P.T.Wallace Starlink 18 July 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION RA,DEC,RAZ,DECZ,XI,ETA
INTEGER J
DOUBLE PRECISION SDECZ,SDEC,CDECZ,CDEC,
: RADIF,SRADIF,CRADIF,DENOM
DOUBLE PRECISION TINY
PARAMETER (TINY=1D-6)
* Trig functions
SDECZ=SIN(DECZ)
SDEC=SIN(DEC)
CDECZ=COS(DECZ)
CDEC=COS(DEC)
RADIF=RA-RAZ
SRADIF=SIN(RADIF)
CRADIF=COS(RADIF)
* Reciprocal of star vector length to tangent plane
DENOM=SDEC*SDECZ+CDEC*CDECZ*CRADIF
* Handle vectors too far from axis
IF (DENOM.GT.TINY) THEN
J=0
ELSE IF (DENOM.GE.0D0) THEN
J=1
DENOM=TINY
ELSE IF (DENOM.GT.-TINY) THEN
J=2
DENOM=-TINY
ELSE
J=3
END IF
* Compute tangent plane coordinates (even in dubious cases)
XI=CDEC*SRADIF/DENOM
ETA=(SDEC*CDECZ-CDEC*SDECZ*CRADIF)/DENOM
END

60
slalib/dsep.f Normal file
View File

@ -0,0 +1,60 @@
DOUBLE PRECISION FUNCTION sla_DSEP (A1, B1, A2, B2)
*+
* - - - - -
* D S E P
* - - - - -
*
* Angle between two points on a sphere.
*
* (double precision)
*
* Given:
* A1,B1 d spherical coordinates of one point
* A2,B2 d spherical coordinates of the other point
*
* (The spherical coordinates are [RA,Dec], [Long,Lat] etc, in radians.)
*
* The result is the angle, in radians, between the two points. It
* is always positive.
*
* Called: sla_DCS2C, sla_DSEPV
*
* Last revision: 7 May 2000
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION A1,B1,A2,B2
DOUBLE PRECISION V1(3),V2(3)
DOUBLE PRECISION sla_DSEPV
* Convert coordinates from spherical to Cartesian.
CALL sla_DCS2C(A1,B1,V1)
CALL sla_DCS2C(A2,B2,V2)
* Angle between the vectors.
sla_DSEP = sla_DSEPV(V1,V2)
END

76
slalib/dsepv.f Normal file
View File

@ -0,0 +1,76 @@
DOUBLE PRECISION FUNCTION sla_DSEPV (V1, V2)
*+
* - - - - - -
* D S E P V
* - - - - - -
*
* Angle between two vectors.
*
* (double precision)
*
* Given:
* V1 d(3) first vector
* V2 d(3) second vector
*
* The result is the angle, in radians, between the two vectors. It
* is always positive.
*
* Notes:
*
* 1 There is no requirement for the vectors to be unit length.
*
* 2 If either vector is null, zero is returned.
*
* 3 The simplest formulation would use dot product alone. However,
* this would reduce the accuracy for angles near zero and pi. The
* algorithm uses both cross product and dot product, which maintains
* accuracy for all sizes of angle.
*
* Called: sla_DVXV, sla_DVN, sla_DVDV
*
* Last revision: 14 June 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION V1(3),V2(3)
DOUBLE PRECISION V1XV2(3),WV(3),S,C
DOUBLE PRECISION sla_DVDV
* Modulus of cross product = sine multiplied by the two moduli.
CALL sla_DVXV(V1,V2,V1XV2)
CALL sla_DVN(V1XV2,WV,S)
* Dot product = cosine multiplied by the two moduli.
C = sla_DVDV(V1,V2)
* Angle between the vectors.
IF ( S.NE.0D0 .OR. C.NE.0D0 ) THEN
sla_DSEPV = ATAN2(S,C)
ELSE
sla_DSEPV = 0D0
END IF
END

96
slalib/dt.f Normal file
View File

@ -0,0 +1,96 @@
DOUBLE PRECISION FUNCTION sla_DT (EPOCH)
*+
* - - -
* D T
* - - -
*
* Estimate the offset between dynamical time and Universal Time
* for a given historical epoch.
*
* Given:
* EPOCH d (Julian) epoch (e.g. 1850D0)
*
* The result is a rough estimate of ET-UT (after 1984, TT-UT) at
* the given epoch, in seconds.
*
* Notes:
*
* 1 Depending on the epoch, one of three parabolic approximations
* is used:
*
* before 979 Stephenson & Morrison's 390 BC to AD 948 model
* 979 to 1708 Stephenson & Morrison's 948 to 1600 model
* after 1708 McCarthy & Babcock's post-1650 model
*
* The breakpoints are chosen to ensure continuity: they occur
* at places where the adjacent models give the same answer as
* each other.
*
* 2 The accuracy is modest, with errors of up to 20 sec during
* the interval since 1650, rising to perhaps 30 min by 1000 BC.
* Comparatively accurate values from AD 1600 are tabulated in
* the Astronomical Almanac (see section K8 of the 1995 AA).
*
* 3 The use of double-precision for both argument and result is
* purely for compatibility with other SLALIB time routines.
*
* 4 The models used are based on a lunar tidal acceleration value
* of -26.00 arcsec per century.
*
* Reference: Explanatory Supplement to the Astronomical Almanac,
* ed P.K.Seidelmann, University Science Books (1992),
* section 2.553, p83. This contains references to
* the Stephenson & Morrison and McCarthy & Babcock
* papers.
*
* P.T.Wallace Starlink 1 March 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION EPOCH
DOUBLE PRECISION T,W,S
* Centuries since 1800
T=(EPOCH-1800D0)/100D0
* Select model
IF (EPOCH.GE.1708.185161980887D0) THEN
* Post-1708: use McCarthy & Babcock
W=T-0.19D0
S=5.156D0+13.3066D0*W*W
ELSE IF (EPOCH.GE.979.0258204760233D0) THEN
* 979-1708: use Stephenson & Morrison's 948-1600 model
S=25.5D0*T*T
ELSE
* Pre-979: use Stephenson & Morrison's 390 BC to AD 948 model
S=1360.0D0+(320D0+44.3D0*T)*T
END IF
* Result
sla_DT=S
END

72
slalib/dtf2d.f Normal file
View File

@ -0,0 +1,72 @@
SUBROUTINE sla_DTF2D (IHOUR, IMIN, SEC, DAYS, J)
*+
* - - - - - -
* D T F 2 D
* - - - - - -
*
* Convert hours, minutes, seconds to days (double precision)
*
* Given:
* IHOUR int hours
* IMIN int minutes
* SEC dp seconds
*
* Returned:
* DAYS dp interval in days
* J int status: 0 = OK
* 1 = IHOUR outside range 0-23
* 2 = IMIN outside range 0-59
* 3 = SEC outside range 0-59.999...
*
* Notes:
*
* 1) The result is computed even if any of the range checks fail.
*
* 2) The sign must be dealt with outside this routine.
*
* P.T.Wallace Starlink July 1984
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IHOUR,IMIN
DOUBLE PRECISION SEC,DAYS
INTEGER J
* Seconds per day
DOUBLE PRECISION D2S
PARAMETER (D2S=86400D0)
* Preset status
J=0
* Validate sec, min, hour
IF (SEC.LT.0D0.OR.SEC.GE.60D0) J=3
IF (IMIN.LT.0.OR.IMIN.GT.59) J=2
IF (IHOUR.LT.0.OR.IHOUR.GT.23) J=1
* Compute interval
DAYS=(60D0*(60D0*DBLE(IHOUR)+DBLE(IMIN))+SEC)/D2S
END

70
slalib/dtf2r.f Normal file
View File

@ -0,0 +1,70 @@
SUBROUTINE sla_DTF2R (IHOUR, IMIN, SEC, RAD, J)
*+
* - - - - - -
* D T F 2 R
* - - - - - -
*
* Convert hours, minutes, seconds to radians (double precision)
*
* Given:
* IHOUR int hours
* IMIN int minutes
* SEC dp seconds
*
* Returned:
* RAD dp angle in radians
* J int status: 0 = OK
* 1 = IHOUR outside range 0-23
* 2 = IMIN outside range 0-59
* 3 = SEC outside range 0-59.999...
*
* Called:
* sla_DTF2D
*
* Notes:
*
* 1) The result is computed even if any of the range checks fail.
*
* 2) The sign must be dealt with outside this routine.
*
* P.T.Wallace Starlink July 1984
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IHOUR,IMIN
DOUBLE PRECISION SEC,RAD
INTEGER J
DOUBLE PRECISION TURNS
* Turns to radians
DOUBLE PRECISION T2R
PARAMETER (T2R=6.283185307179586476925287D0)
* Convert to turns then radians
CALL sla_DTF2D(IHOUR,IMIN,SEC,TURNS,J)
RAD=T2R*TURNS
END

59
slalib/dtp2s.f Normal file
View File

@ -0,0 +1,59 @@
SUBROUTINE sla_DTP2S (XI, ETA, RAZ, DECZ, RA, DEC)
*+
* - - - - - -
* D T P 2 S
* - - - - - -
*
* Transform tangent plane coordinates into spherical
* (double precision)
*
* Given:
* XI,ETA dp tangent plane rectangular coordinates
* RAZ,DECZ dp spherical coordinates of tangent point
*
* Returned:
* RA,DEC dp spherical coordinates (0-2pi,+/-pi/2)
*
* Called: sla_DRANRM
*
* P.T.Wallace Starlink 24 July 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION XI,ETA,RAZ,DECZ,RA,DEC
DOUBLE PRECISION sla_DRANRM
DOUBLE PRECISION SDECZ,CDECZ,DENOM
SDECZ=SIN(DECZ)
CDECZ=COS(DECZ)
DENOM=CDECZ-ETA*SDECZ
RA=sla_DRANRM(ATAN2(XI,DENOM)+RAZ)
DEC=ATAN2(SDECZ+ETA*CDECZ,SQRT(XI*XI+DENOM*DENOM))
END

73
slalib/dtp2v.f Normal file
View File

@ -0,0 +1,73 @@
SUBROUTINE sla_DTP2V (XI, ETA, V0, V)
*+
* - - - - - -
* D T P 2 V
* - - - - - -
*
* Given the tangent-plane coordinates of a star and the direction
* cosines of the tangent point, determine the direction cosines
* of the star.
*
* (double precision)
*
* Given:
* XI,ETA d tangent plane coordinates of star
* V0 d(3) direction cosines of tangent point
*
* Returned:
* V d(3) direction cosines of star
*
* Notes:
*
* 1 If vector V0 is not of unit length, the returned vector V will
* be wrong.
*
* 2 If vector V0 points at a pole, the returned vector V will be
* based on the arbitrary assumption that the RA of the tangent
* point is zero.
*
* 3 This routine is the Cartesian equivalent of the routine sla_DTP2S.
*
* P.T.Wallace Starlink 11 February 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION XI,ETA,V0(3),V(3)
DOUBLE PRECISION X,Y,Z,F,R
X=V0(1)
Y=V0(2)
Z=V0(3)
F=SQRT(1D0+XI*XI+ETA*ETA)
R=SQRT(X*X+Y*Y)
IF (R.EQ.0D0) THEN
R=1D-20
X=R
END IF
V(1)=(X-(XI*Y+ETA*X*Z)/R)/F
V(2)=(Y+(XI*X-ETA*Y*Z)/R)/F
V(3)=(Z+ETA*R)/F
END

108
slalib/dtps2c.f Normal file
View File

@ -0,0 +1,108 @@
SUBROUTINE sla_DTPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1,
: RAZ2, DECZ2, N)
*+
* - - - - - - -
* D T P S 2 C
* - - - - - - -
*
* From the tangent plane coordinates of a star of known RA,Dec,
* determine the RA,Dec of the tangent point.
*
* (double precision)
*
* Given:
* XI,ETA d tangent plane rectangular coordinates
* RA,DEC d spherical coordinates
*
* Returned:
* RAZ1,DECZ1 d spherical coordinates of tangent point, solution 1
* RAZ2,DECZ2 d spherical coordinates of tangent point, solution 2
* N i number of solutions:
* 0 = no solutions returned (note 2)
* 1 = only the first solution is useful (note 3)
* 2 = both solutions are useful (note 3)
*
* Notes:
*
* 1 The RAZ1 and RAZ2 values are returned in the range 0-2pi.
*
* 2 Cases where there is no solution can only arise near the poles.
* For example, it is clearly impossible for a star at the pole
* itself to have a non-zero XI value, and hence it is
* meaningless to ask where the tangent point would have to be
* to bring about this combination of XI and DEC.
*
* 3 Also near the poles, cases can arise where there are two useful
* solutions. The argument N indicates whether the second of the
* two solutions returned is useful. N=1 indicates only one useful
* solution, the usual case; under these circumstances, the second
* solution corresponds to the "over-the-pole" case, and this is
* reflected in the values of RAZ2 and DECZ2 which are returned.
*
* 4 The DECZ1 and DECZ2 values are returned in the range +/-pi, but
* in the usual, non-pole-crossing, case, the range is +/-pi/2.
*
* 5 This routine is the spherical equivalent of the routine sla_DTPV2C.
*
* Called: sla_DRANRM
*
* P.T.Wallace Starlink 5 June 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION XI,ETA,RA,DEC,RAZ1,DECZ1,RAZ2,DECZ2
INTEGER N
DOUBLE PRECISION X2,Y2,SD,CD,SDF,R2,R,S,C
DOUBLE PRECISION sla_DRANRM
X2=XI*XI
Y2=ETA*ETA
SD=SIN(DEC)
CD=COS(DEC)
SDF=SD*SQRT(1D0+X2+Y2)
R2=CD*CD*(1D0+Y2)-SD*SD*X2
IF (R2.GE.0D0) THEN
R=SQRT(R2)
S=SDF-ETA*R
C=SDF*ETA+R
IF (XI.EQ.0D0.AND.R.EQ.0D0) R=1D0
RAZ1=sla_DRANRM(RA-ATAN2(XI,R))
DECZ1=ATAN2(S,C)
R=-R
S=SDF-ETA*R
C=SDF*ETA+R
RAZ2=sla_DRANRM(RA-ATAN2(XI,R))
DECZ2=ATAN2(S,C)
IF (ABS(SDF).LT.1D0) THEN
N=1
ELSE
N=2
END IF
ELSE
N=0
END IF
END

100
slalib/dtpv2c.f Normal file
View File

@ -0,0 +1,100 @@
SUBROUTINE sla_DTPV2C (XI, ETA, V, V01, V02, N)
*+
* - - - - - - -
* D T P V 2 C
* - - - - - - -
*
* Given the tangent-plane coordinates of a star and its direction
* cosines, determine the direction cosines of the tangent-point.
*
* (double precision)
*
* Given:
* XI,ETA d tangent plane coordinates of star
* V d(3) direction cosines of star
*
* Returned:
* V01 d(3) direction cosines of tangent point, solution 1
* V02 d(3) direction cosines of tangent point, solution 2
* N i number of solutions:
* 0 = no solutions returned (note 2)
* 1 = only the first solution is useful (note 3)
* 2 = both solutions are useful (note 3)
*
* Notes:
*
* 1 The vector V must be of unit length or the result will be wrong.
*
* 2 Cases where there is no solution can only arise near the poles.
* For example, it is clearly impossible for a star at the pole
* itself to have a non-zero XI value, and hence it is meaningless
* to ask where the tangent point would have to be.
*
* 3 Also near the poles, cases can arise where there are two useful
* solutions. The argument N indicates whether the second of the
* two solutions returned is useful. N=1 indicates only one useful
* solution, the usual case; under these circumstances, the second
* solution can be regarded as valid if the vector V02 is interpreted
* as the "over-the-pole" case.
*
* 4 This routine is the Cartesian equivalent of the routine sla_DTPS2C.
*
* P.T.Wallace Starlink 5 June 1995
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION XI,ETA,V(3),V01(3),V02(3)
INTEGER N
DOUBLE PRECISION X,Y,Z,RXY2,XI2,ETA2P1,SDF,R2,R,C
X=V(1)
Y=V(2)
Z=V(3)
RXY2=X*X+Y*Y
XI2=XI*XI
ETA2P1=ETA*ETA+1D0
SDF=Z*SQRT(XI2+ETA2P1)
R2=RXY2*ETA2P1-Z*Z*XI2
IF (R2.GT.0D0) THEN
R=SQRT(R2)
C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2)))
V01(1)=C*(X*R+Y*XI)
V01(2)=C*(Y*R-X*XI)
V01(3)=(SDF-ETA*R)/ETA2P1
R=-R
C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2)))
V02(1)=C*(X*R+Y*XI)
V02(2)=C*(Y*R-X*XI)
V02(3)=(SDF-ETA*R)/ETA2P1
IF (ABS(SDF).LT.1D0) THEN
N=1
ELSE
N=2
END IF
ELSE
N=0
END IF
END

63
slalib/dtt.f Normal file
View File

@ -0,0 +1,63 @@
DOUBLE PRECISION FUNCTION sla_DTT (UTC)
*+
* - - - -
* D T T
* - - - -
*
* Increment to be applied to Coordinated Universal Time UTC to give
* Terrestrial Time TT (formerly Ephemeris Time ET)
*
* (double precision)
*
* Given:
* UTC d UTC date as a modified JD (JD-2400000.5)
*
* Result: TT-UTC in seconds
*
* Notes:
*
* 1 The UTC is specified to be a date rather than a time to indicate
* that care needs to be taken not to specify an instant which lies
* within a leap second. Though in most cases UTC can include the
* fractional part, correct behaviour on the day of a leap second
* can only be guaranteed up to the end of the second 23:59:59.
*
* 2 Pre 1972 January 1 a fixed value of 10 + ET-TAI is returned.
*
* 3 See also the routine sla_DT, which roughly estimates ET-UT for
* historical epochs.
*
* Called: sla_DAT
*
* P.T.Wallace Starlink 6 December 1994
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION UTC
DOUBLE PRECISION sla_DAT
sla_DTT=32.184D0+sla_DAT(UTC)
END

95
slalib/dv2tp.f Normal file
View File

@ -0,0 +1,95 @@
SUBROUTINE sla_DV2TP (V, V0, XI, ETA, J)
*+
* - - - - - -
* D V 2 T P
* - - - - - -
*
* Given the direction cosines of a star and of the tangent point,
* determine the star's tangent-plane coordinates.
*
* (double precision)
*
* Given:
* V d(3) direction cosines of star
* V0 d(3) direction cosines of tangent point
*
* Returned:
* XI,ETA d tangent plane coordinates of star
* J i status: 0 = OK
* 1 = error, star too far from axis
* 2 = error, antistar on tangent plane
* 3 = error, antistar too far from axis
*
* Notes:
*
* 1 If vector V0 is not of unit length, or if vector V is of zero
* length, the results will be wrong.
*
* 2 If V0 points at a pole, the returned XI,ETA will be based on the
* arbitrary assumption that the RA of the tangent point is zero.
*
* 3 This routine is the Cartesian equivalent of the routine sla_DS2TP.
*
* P.T.Wallace Starlink 27 November 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION V(3),V0(3),XI,ETA
INTEGER J
DOUBLE PRECISION X,Y,Z,X0,Y0,Z0,R2,R,W,D
DOUBLE PRECISION TINY
PARAMETER (TINY=1D-6)
X=V(1)
Y=V(2)
Z=V(3)
X0=V0(1)
Y0=V0(2)
Z0=V0(3)
R2=X0*X0+Y0*Y0
R=SQRT(R2)
IF (R.EQ.0D0) THEN
R=1D-20
X0=R
END IF
W=X*X0+Y*Y0
D=W+Z*Z0
IF (D.GT.TINY) THEN
J=0
ELSE IF (D.GE.0D0) THEN
J=1
D=TINY
ELSE IF (D.GT.-TINY) THEN
J=2
D=-TINY
ELSE
J=3
END IF
D=D*R
XI=(Y*X0-X*Y0)/D
ETA=(Z*R2-Z0*W)/D
END

44
slalib/dvdv.f Normal file
View File

@ -0,0 +1,44 @@
DOUBLE PRECISION FUNCTION sla_DVDV (VA, VB)
*+
* - - - - -
* D V D V
* - - - - -
*
* Scalar product of two 3-vectors (double precision)
*
* Given:
* VA dp(3) first vector
* VB dp(3) second vector
*
* The result is the scalar product VA.VB (double precision)
*
* P.T.Wallace Starlink November 1984
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION VA(3),VB(3)
sla_DVDV=VA(1)*VB(1)+VA(2)*VB(2)+VA(3)*VB(3)
END

69
slalib/dvn.f Normal file
View File

@ -0,0 +1,69 @@
SUBROUTINE sla_DVN (V, UV, VM)
*+
* - - - -
* D V N
* - - - -
*
* Normalizes a 3-vector also giving the modulus (double precision)
*
* Given:
* V d(3) vector
*
* Returned:
* UV d(3) unit vector in direction of V
* VM d modulus of V
*
* Notes:
*
* 1 If the modulus of V is zero, UV is set to zero as well.
*
* 2 To comply with the ANSI Fortran 77 standard, V and UV must be
* different arrays. However, the routine is coded so as to work
* properly on most platforms even if this rule is violated.
*
* Last revision: 22 July 2004
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION V(3),UV(3),VM
INTEGER I
DOUBLE PRECISION W1,W2
* Modulus.
W1 = 0D0
DO I=1,3
W2 = V(I)
W1 = W1+W2*W2
END DO
W1 = SQRT(W1)
VM = W1
* Normalize the vector.
IF (W1.LE.0D0) W1 = 1D0
DO I=1,3
UV(I) = V(I)/W1
END DO
END

56
slalib/dvxv.f Normal file
View File

@ -0,0 +1,56 @@
SUBROUTINE sla_DVXV (VA, VB, VC)
*+
* - - - - -
* D V X V
* - - - - -
*
* Vector product of two 3-vectors (double precision)
*
* Given:
* VA dp(3) first vector
* VB dp(3) second vector
*
* Returned:
* VC dp(3) vector result
*
* P.T.Wallace Starlink March 1986
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION VA(3),VB(3),VC(3)
DOUBLE PRECISION VW(3)
INTEGER I
* Form the vector product VA cross VB
VW(1)=VA(2)*VB(3)-VA(3)*VB(2)
VW(2)=VA(3)*VB(1)-VA(1)*VB(3)
VW(3)=VA(1)*VB(2)-VA(2)*VB(1)
* Return the result
DO I=1,3
VC(I)=VW(I)
END DO
END

106
slalib/e2h.f Normal file
View File

@ -0,0 +1,106 @@
SUBROUTINE sla_E2H (HA, DEC, PHI, AZ, EL)
*+
* - - - -
* E 2 H
* - - - -
*
* Equatorial to horizon coordinates: HA,Dec to Az,El
*
* (single precision)
*
* Given:
* HA r hour angle
* DEC r declination
* PHI r observatory latitude
*
* Returned:
* AZ r azimuth
* EL r elevation
*
* Notes:
*
* 1) All the arguments are angles in radians.
*
* 2) Azimuth is returned in the range 0-2pi; north is zero,
* and east is +pi/2. Elevation is returned in the range
* +/-pi/2.
*
* 3) The latitude must be geodetic. In critical applications,
* corrections for polar motion should be applied.
*
* 4) In some applications it will be important to specify the
* correct type of hour angle and declination in order to
* produce the required type of azimuth and elevation. In
* particular, it may be important to distinguish between
* elevation as affected by refraction, which would
* require the "observed" HA,Dec, and the elevation
* in vacuo, which would require the "topocentric" HA,Dec.
* If the effects of diurnal aberration can be neglected, the
* "apparent" HA,Dec may be used instead of the topocentric
* HA,Dec.
*
* 5) No range checking of arguments is carried out.
*
* 6) In applications which involve many such calculations, rather
* than calling the present routine it will be more efficient to
* use inline code, having previously computed fixed terms such
* as sine and cosine of latitude, and (for tracking a star)
* sine and cosine of declination.
*
* P.T.Wallace Starlink 9 July 1994
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL HA,DEC,PHI,AZ,EL
REAL R2PI
PARAMETER (R2PI=6.283185307179586476925286766559)
REAL SH,CH,SD,CD,SP,CP,X,Y,Z,R,A
* Useful trig functions
SH=SIN(HA)
CH=COS(HA)
SD=SIN(DEC)
CD=COS(DEC)
SP=SIN(PHI)
CP=COS(PHI)
* Az,El as x,y,z
X=-CH*CD*SP+SD*CP
Y=-SH*CD
Z=CH*CD*CP+SD*SP
* To spherical
R=SQRT(X*X+Y*Y)
IF (R.EQ.0.0) THEN
A=0.0
ELSE
A=ATAN2(Y,X)
END IF
IF (A.LT.0.0) A=A+R2PI
AZ=A
EL=ATAN2(Z,R)
END

129
slalib/earth.f Normal file
View File

@ -0,0 +1,129 @@
SUBROUTINE sla_EARTH (IY, ID, FD, PV)
*+
* - - - - - -
* E A R T H
* - - - - - -
*
* Approximate heliocentric position and velocity of the Earth
*
* Given:
* IY I year
* ID I day in year (1 = Jan 1st)
* FD R fraction of day
*
* Returned:
* PV R(6) Earth position & velocity vector
*
* Notes:
*
* 1 The date and time is TDB (loosely ET) in a Julian calendar
* which has been aligned to the ordinary Gregorian
* calendar for the interval 1900 March 1 to 2100 February 28.
* The year and day can be obtained by calling sla_CALYD or
* sla_CLYD.
*
* 2 The Earth heliocentric 6-vector is mean equator and equinox
* of date. Position part, PV(1-3), is in AU; velocity part,
* PV(4-6), is in AU/sec.
*
* 3 Max/RMS errors 1950-2050:
* 13/5 E-5 AU = 19200/7600 km in position
* 47/26 E-10 AU/s = 0.0070/0.0039 km/s in speed
*
* 4 More accurate results are obtainable with the routines sla_EVP
* and sla_EPV.
*
* Last revision: 5 April 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
INTEGER IY,ID
REAL FD,PV(6)
INTEGER IY4
REAL TWOPI,SPEED,REMB,SEMB,YI,YF,T,ELM,GAMMA,EM,ELT,EPS0,
: E,ESQ,V,R,ELMM,COSELT,SINEPS,COSEPS,W1,W2,SELMM,CELMM
PARAMETER (TWOPI=6.28318530718)
* Mean orbital speed of Earth, AU/s
PARAMETER (SPEED=1.9913E-7)
* Mean Earth:EMB distance and speed, AU and AU/s
PARAMETER (REMB=3.12E-5,SEMB=8.31E-11)
* Whole years & fraction of year, and years since J1900.0
YI=FLOAT(IY-1900)
IY4=MOD(MOD(IY,4)+4,4)
YF=(FLOAT(4*(ID-1/(IY4+1))-IY4-2)+4.0*FD)/1461.0
T=YI+YF
* Geometric mean longitude of Sun
* (cf 4.881627938+6.283319509911*T MOD 2PI)
ELM=MOD(4.881628+TWOPI*YF+0.00013420*T,TWOPI)
* Mean longitude of perihelion
GAMMA=4.908230+3.0005E-4*T
* Mean anomaly
EM=ELM-GAMMA
* Mean obliquity
EPS0=0.40931975-2.27E-6*T
* Eccentricity
E=0.016751-4.2E-7*T
ESQ=E*E
* True anomaly
V=EM+2.0*E*SIN(EM)+1.25*ESQ*SIN(2.0*EM)
* True ecliptic longitude
ELT=V+GAMMA
* True distance
R=(1.0-ESQ)/(1.0+E*COS(V))
* Moon's mean longitude
ELMM=MOD(4.72+83.9971*T,TWOPI)
* Useful functions
COSELT=COS(ELT)
SINEPS=SIN(EPS0)
COSEPS=COS(EPS0)
W1=-R*SIN(ELT)
W2=-SPEED*(COSELT+E*COS(GAMMA))
SELMM=SIN(ELMM)
CELMM=COS(ELMM)
* Earth position and velocity
PV(1)=-R*COSELT-REMB*CELMM
PV(2)=(W1-REMB*SELMM)*COSEPS
PV(3)=W1*SINEPS
PV(4)=SPEED*(SIN(ELT)+E*SIN(GAMMA))+SEMB*SELMM
PV(5)=(W2-SEMB*CELMM)*COSEPS
PV(6)=W2*SINEPS
END

72
slalib/ecleq.f Normal file
View File

@ -0,0 +1,72 @@
SUBROUTINE sla_ECLEQ (DL, DB, DATE, DR, DD)
*+
* - - - - - -
* E C L E Q
* - - - - - -
*
* Transformation from ecliptic coordinates to
* J2000.0 equatorial coordinates (double precision)
*
* Given:
* DL,DB dp ecliptic longitude and latitude
* (mean of date, IAU 1980 theory, radians)
* DATE dp TDB (loosely ET) as Modified Julian Date
* (JD-2400000.5)
* Returned:
* DR,DD dp J2000.0 mean RA,Dec (radians)
*
* Called:
* sla_DCS2C, sla_ECMAT, sla_DIMXV, sla_PREC, sla_EPJ, sla_DCC2S,
* sla_DRANRM, sla_DRANGE
*
* P.T.Wallace Starlink March 1986
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DL,DB,DATE,DR,DD
DOUBLE PRECISION sla_EPJ,sla_DRANRM,sla_DRANGE
DOUBLE PRECISION RMAT(3,3),V1(3),V2(3)
* Spherical to Cartesian
CALL sla_DCS2C(DL,DB,V1)
* Ecliptic to equatorial
CALL sla_ECMAT(DATE,RMAT)
CALL sla_DIMXV(RMAT,V1,V2)
* Mean of date to J2000
CALL sla_PREC(2000D0,sla_EPJ(DATE),RMAT)
CALL sla_DIMXV(RMAT,V2,V1)
* Cartesian to spherical
CALL sla_DCC2S(V1,DR,DD)
* Express in conventional ranges
DR=sla_DRANRM(DR)
DD=sla_DRANGE(DD)
END

69
slalib/ecmat.f Normal file
View File

@ -0,0 +1,69 @@
SUBROUTINE sla_ECMAT (DATE, RMAT)
*+
* - - - - - -
* E C M A T
* - - - - - -
*
* Form the equatorial to ecliptic rotation matrix - IAU 1980 theory
* (double precision)
*
* Given:
* DATE dp TDB (loosely ET) as Modified Julian Date
* (JD-2400000.5)
* Returned:
* RMAT dp(3,3) matrix
*
* Reference:
* Murray,C.A., Vectorial Astrometry, section 4.3.
*
* Note:
* The matrix is in the sense V(ecl) = RMAT * V(equ); the
* equator, equinox and ecliptic are mean of date.
*
* Called: sla_DEULER
*
* P.T.Wallace Starlink 23 August 1996
*
* Copyright (C) 1996 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DATE,RMAT(3,3)
* Arc seconds to radians
DOUBLE PRECISION AS2R
PARAMETER (AS2R=0.484813681109535994D-5)
DOUBLE PRECISION T,EPS0
* Interval between basic epoch J2000.0 and current epoch (JC)
T = (DATE-51544.5D0)/36525D0
* Mean obliquity
EPS0 = AS2R*
: (84381.448D0+(-46.8150D0+(-0.00059D0+0.001813D0*T)*T)*T)
* Matrix
CALL sla_DEULER('X',EPS0,0D0,0D0,RMAT)
END

95
slalib/ecor.f Normal file
View File

@ -0,0 +1,95 @@
SUBROUTINE sla_ECOR (RM, DM, IY, ID, FD, RV, TL)
*+
* - - - - -
* E C O R
* - - - - -
*
* Component of Earth orbit velocity and heliocentric
* light time in a given direction (single precision)
*
* Given:
* RM,DM real mean RA, Dec of date (radians)
* IY int year
* ID int day in year (1 = Jan 1st)
* FD real fraction of day
*
* Returned:
* RV real component of Earth orbital velocity (km/sec)
* TL real component of heliocentric light time (sec)
*
* Notes:
*
* 1 The date and time is TDB (loosely ET) in a Julian calendar
* which has been aligned to the ordinary Gregorian
* calendar for the interval 1900 March 1 to 2100 February 28.
* The year and day can be obtained by calling sla_CALYD or
* sla_CLYD.
*
* 2 Sign convention:
*
* The velocity component is +ve when the Earth is receding from
* the given point on the sky. The light time component is +ve
* when the Earth lies between the Sun and the given point on
* the sky.
*
* 3 Accuracy:
*
* The velocity component is usually within 0.004 km/s of the
* correct value and is never in error by more than 0.007 km/s.
* The error in light time correction is about 0.03s at worst,
* but is usually better than 0.01s. For applications requiring
* higher accuracy, see the sla_EVP and sla_EPV routines.
*
* Called: sla_EARTH, sla_CS2C, sla_VDV
*
* Last revision: 5 April 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
REAL RM,DM
INTEGER IY,ID
REAL FD,RV,TL
REAL sla_VDV
REAL PV(6),V(3),AUKM,AUSEC
* AU to km and light sec (1985 Almanac)
PARAMETER (AUKM=1.4959787066E8,
: AUSEC=499.0047837)
* Sun:Earth position & velocity vector
CALL sla_EARTH(IY,ID,FD,PV)
* Star position vector
CALL sla_CS2C(RM,DM,V)
* Velocity component
RV=-AUKM*sla_VDV(PV(4),V)
* Light time component
TL=AUSEC*sla_VDV(PV(1),V)
END

107
slalib/eg50.f Normal file
View File

@ -0,0 +1,107 @@
SUBROUTINE sla_EG50 (DR, DD, DL, DB)
*+
* - - - - -
* E G 5 0
* - - - - -
*
* Transformation from B1950.0 'FK4' equatorial coordinates to
* IAU 1958 galactic coordinates (double precision)
*
* Given:
* DR,DD dp B1950.0 'FK4' RA,Dec
*
* Returned:
* DL,DB dp galactic longitude and latitude L2,B2
*
* (all arguments are radians)
*
* Called:
* sla_DCS2C, sla_DMXV, sla_DCC2S, sla_SUBET, sla_DRANRM, sla_DRANGE
*
* Note:
* The equatorial coordinates are B1950.0 'FK4'. Use the
* routine sla_EQGAL if conversion from J2000.0 coordinates
* is required.
*
* Reference:
* Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960)
*
* P.T.Wallace Starlink 5 September 1993
*
* Copyright (C) 1995 Rutherford Appleton Laboratory
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DR,DD,DL,DB
DOUBLE PRECISION sla_DRANRM,sla_DRANGE
DOUBLE PRECISION V1(3),V2(3),R,D
*
* L2,B2 system of galactic coordinates
*
* P = 192.25 RA of galactic north pole (mean B1950.0)
* Q = 62.6 inclination of galactic to mean B1950.0 equator
* R = 33 longitude of ascending node
*
* P,Q,R are degrees
*
*
* Equatorial to galactic rotation matrix
*
* The Euler angles are P, Q, 90-R, about the z then y then
* z axes.
*
* +CP.CQ.SR-SP.CR +SP.CQ.SR+CP.CR -SQ.SR
*
* -CP.CQ.CR-SP.SR -SP.CQ.CR+CP.SR +SQ.CR
*
* +CP.SQ +SP.SQ +CQ
*
DOUBLE PRECISION RMAT(3,3)
DATA RMAT(1,1),RMAT(1,2),RMAT(1,3),
: RMAT(2,1),RMAT(2,2),RMAT(2,3),
: RMAT(3,1),RMAT(3,2),RMAT(3,3) /
: -0.066988739415D0,-0.872755765852D0,-0.483538914632D0,
: +0.492728466075D0,-0.450346958020D0,+0.744584633283D0,
: -0.867600811151D0,-0.188374601723D0,+0.460199784784D0 /
* Remove E-terms
CALL sla_SUBET(DR,DD,1950D0,R,D)
* Spherical to Cartesian
CALL sla_DCS2C(R,D,V1)
* Rotate to galactic
CALL sla_DMXV(RMAT,V1,V2)
* Cartesian to spherical
CALL sla_DCC2S(V2,DL,DB)
* Express angles in conventional ranges
DL=sla_DRANRM(DL)
DB=sla_DRANGE(DB)
END

328
slalib/el2ue.f Normal file
View File

@ -0,0 +1,328 @@
SUBROUTINE sla_EL2UE (DATE, JFORM, EPOCH, ORBINC, ANODE,
: PERIH, AORQ, E, AORL, DM,
: U, JSTAT)
*+
* - - - - - -
* E L 2 U E
* - - - - - -
*
* Transform conventional osculating orbital elements into "universal"
* form.
*
* Given:
* DATE d epoch (TT MJD) of osculation (Note 3)
* JFORM i choice of element set (1-3, Note 6)
* EPOCH d epoch (TT MJD) of the elements
* ORBINC d inclination (radians)
* ANODE d longitude of the ascending node (radians)
* PERIH d longitude or argument of perihelion (radians)
* AORQ d mean distance or perihelion distance (AU)
* E d eccentricity
* AORL d mean anomaly or longitude (radians, JFORM=1,2 only)
* DM d daily motion (radians, JFORM=1 only)
*
* Returned:
* U d(13) universal orbital elements (Note 1)
*
* (1) combined mass (M+m)
* (2) total energy of the orbit (alpha)
* (3) reference (osculating) epoch (t0)
* (4-6) position at reference epoch (r0)
* (7-9) velocity at reference epoch (v0)
* (10) heliocentric distance at reference epoch
* (11) r0.v0
* (12) date (t)
* (13) universal eccentric anomaly (psi) of date, approx
*
* JSTAT i status: 0 = OK
* -1 = illegal JFORM
* -2 = illegal E
* -3 = illegal AORQ
* -4 = illegal DM
* -5 = numerical error
*
* Called: sla_UE2PV, sla_PV2UE
*
* Notes
*
* 1 The "universal" elements are those which define the orbit for the
* purposes of the method of universal variables (see reference).
* They consist of the combined mass of the two bodies, an epoch,
* and the position and velocity vectors (arbitrary reference frame)
* at that epoch. The parameter set used here includes also various
* quantities that can, in fact, be derived from the other
* information. This approach is taken to avoiding unnecessary
* computation and loss of accuracy. The supplementary quantities
* are (i) alpha, which is proportional to the total energy of the
* orbit, (ii) the heliocentric distance at epoch, (iii) the
* outwards component of the velocity at the given epoch, (iv) an
* estimate of psi, the "universal eccentric anomaly" at a given
* date and (v) that date.
*
* 2 The companion routine is sla_UE2PV. This takes the set of numbers
* that the present routine outputs and uses them to derive the
* object's position and velocity. A single prediction requires one
* call to the present routine followed by one call to sla_UE2PV;
* for convenience, the two calls are packaged as the routine
* sla_PLANEL. Multiple predictions may be made by again calling the
* present routine once, but then calling sla_UE2PV multiple times,
* which is faster than multiple calls to sla_PLANEL.
*
* 3 DATE is the epoch of osculation. It is in the TT timescale
* (formerly Ephemeris Time, ET) and is a Modified Julian Date
* (JD-2400000.5).
*
* 4 The supplied orbital elements are with respect to the J2000
* ecliptic and equinox. The position and velocity parameters
* returned in the array U are with respect to the mean equator and
* equinox of epoch J2000, and are for the perihelion prior to the
* specified epoch.
*
* 5 The universal elements returned in the array U are in canonical
* units (solar masses, AU and canonical days).
*
* 6 Three different element-format options are available:
*
* Option JFORM=1, suitable for the major planets:
*
* EPOCH = epoch of elements (TT MJD)
* ORBINC = inclination i (radians)
* ANODE = longitude of the ascending node, big omega (radians)
* PERIH = longitude of perihelion, curly pi (radians)
* AORQ = mean distance, a (AU)
* E = eccentricity, e (range 0 to <1)
* AORL = mean longitude L (radians)
* DM = daily motion (radians)
*
* Option JFORM=2, suitable for minor planets:
*
* EPOCH = epoch of elements (TT MJD)
* ORBINC = inclination i (radians)
* ANODE = longitude of the ascending node, big omega (radians)
* PERIH = argument of perihelion, little omega (radians)
* AORQ = mean distance, a (AU)
* E = eccentricity, e (range 0 to <1)
* AORL = mean anomaly M (radians)
*
* Option JFORM=3, suitable for comets:
*
* EPOCH = epoch of perihelion (TT MJD)
* ORBINC = inclination i (radians)
* ANODE = longitude of the ascending node, big omega (radians)
* PERIH = argument of perihelion, little omega (radians)
* AORQ = perihelion distance, q (AU)
* E = eccentricity, e (range 0 to 10)
*
* 7 Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are
* not accessed.
*
* 8 The algorithm was originally adapted from the EPHSLA program of
* D.H.P.Jones (private communication, 1996). The method is based
* on Stumpff's Universal Variables.
*
* Reference: Everhart & Pitkin, Am.J.Phys. 51, 712 (1983).
*
* Last revision: 8 September 2005
*
* Copyright P.T.Wallace. All rights reserved.
*
* License:
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program (see SLA_CONDITIONS); if not, write to the
* Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
*-
IMPLICIT NONE
DOUBLE PRECISION DATE
INTEGER JFORM
DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,U(13)
INTEGER JSTAT
* Gaussian gravitational constant (exact)
DOUBLE PRECISION GCON
PARAMETER (GCON=0.01720209895D0)
* Sin and cos of J2000 mean obliquity (IAU 1976)
DOUBLE PRECISION SE,CE
PARAMETER (SE=0.3977771559319137D0,
: CE=0.9174820620691818D0)
INTEGER J
DOUBLE PRECISION PHT,ARGPH,Q,W,CM,ALPHA,PHS,SW,CW,SI,CI,SO,CO,
: X,Y,Z,PX,PY,PZ,VX,VY,VZ,DT,FC,FP,PSI,
: UL(13),PV(6)
* Validate arguments.
IF (JFORM.LT.1.OR.JFORM.GT.3) THEN
JSTAT = -1
GO TO 9999
END IF
IF (E.LT.0D0.OR.E.GT.10D0.OR.(E.GE.1D0.AND.JFORM.NE.3)) THEN
JSTAT = -2
GO TO 9999
END IF
IF (AORQ.LE.0D0) THEN
JSTAT = -3
GO TO 9999
END IF
IF (JFORM.EQ.1.AND.DM.LE.0D0) THEN
JSTAT = -4
GO TO 9999
END IF
*
* Transform elements into standard form:
*
* PHT = epoch of perihelion passage
* ARGPH = argument of perihelion (little omega)
* Q = perihelion distance (q)
* CM = combined mass, M+m (mu)
IF (JFORM.EQ.1) THEN
* Major planet.
PHT = EPOCH-(AORL-PERIH)/DM
ARGPH = PERIH-ANODE
Q = AORQ*(1D0-E)
W = DM/GCON
CM = W*W*AORQ*AORQ*AORQ
ELSE IF (JFORM.EQ.2) THEN
* Minor planet.
PHT = EPOCH-AORL*SQRT(AORQ*AORQ*AORQ)/GCON
ARGPH = PERIH
Q = AORQ*(1D0-E)
CM = 1D0
ELSE
* Comet.
PHT = EPOCH
ARGPH = PERIH
Q = AORQ
CM = 1D0
END IF
* The universal variable alpha. This is proportional to the total
* energy of the orbit: -ve for an ellipse, zero for a parabola,
* +ve for a hyperbola.
ALPHA = CM*(E-1D0)/Q
* Speed at perihelion.
PHS = SQRT(ALPHA+2D0*CM/Q)
* In a Cartesian coordinate system which has the x-axis pointing
* to perihelion and the z-axis normal to the orbit (such that the
* object orbits counter-clockwise as seen from +ve z), the
* perihelion position and velocity vectors are:
*
* position [Q,0,0]
* velocity [0,PHS,0]
*
* To express the results in J2000 equatorial coordinates we make a
* series of four rotations of the Cartesian axes:
*
* axis Euler angle
*
* 1 z argument of perihelion (little omega)
* 2 x inclination (i)
* 3 z longitude of the ascending node (big omega)
* 4 x J2000 obliquity (epsilon)
*
* In each case the rotation is clockwise as seen from the +ve end of
* the axis concerned.
* Functions of the Euler angles.
SW = SIN(ARGPH)
CW = COS(ARGPH)
SI = SIN(ORBINC)
CI = COS(ORBINC)
SO = SIN(ANODE)
CO = COS(ANODE)
* Position at perihelion (AU).
X = Q*CW
Y = Q*SW
Z = Y*SI
Y = Y*CI
PX = X*CO-Y*SO
Y = X*SO+Y*CO
PY = Y*CE-Z*SE
PZ = Y*SE+Z*CE
* Velocity at perihelion (AU per canonical day).
X = -PHS*SW
Y = PHS*CW
Z = Y*SI
Y = Y*CI
VX = X*CO-Y*SO
Y = X*SO+Y*CO
VY = Y*CE-Z*SE
VZ = Y*SE+Z*CE
* Time from perihelion to date (in Canonical Days: a canonical day
* is 58.1324409... days, defined as 1/GCON).
DT = (DATE-PHT)*GCON
* First approximation to the Universal Eccentric Anomaly, PSI,
* based on the circle (FC) and parabola (FP) values.
FC = DT/Q
W = (3D0*DT+SQRT(9D0*DT*DT+8D0*Q*Q*Q))**(1D0/3D0)
FP = W-2D0*Q/W
PSI = (1D0-E)*FC+E*FP
* Assemble local copy of element set.
UL(1) = CM
UL(2) = ALPHA
UL(3) = PHT
UL(4) = PX
UL(5) = PY
UL(6) = PZ
UL(7) = VX
UL(8) = VY
UL(9) = VZ
UL(10) = Q
UL(11) = 0D0
UL(12) = DATE
UL(13) = PSI
* Predict position+velocity at epoch of osculation.
CALL sla_UE2PV(DATE,UL,PV,J)
IF (J.NE.0) GO TO 9010
* Convert back to universal elements.
CALL sla_PV2UE(PV,DATE,CM-1D0,U,J)
IF (J.NE.0) GO TO 9010
* OK exit.
JSTAT = 0
GO TO 9999
* Quasi-impossible numerical errors.
9010 CONTINUE
JSTAT = -5
9999 CONTINUE
END

Some files were not shown because too many files have changed in this diff Show More