perl/DXBearing.pm

   1 #
   2 # bearing and distance calculations together with
   3 # locator convertions to lat/long and back
   4 #
   5 # some of this is nicked from 'Amateur Radio Software' by
   6 # John Morris GM4ANB and tranlated into perl from the original
   7 # basic by me - I have factorised it where I can be bothered
   8 #
   9 # Copyright (c) 1998 - Dirk Koopman G1TLH
  10 #
  11 # $Id$
  12 #
  13
  14 package DXBearing;
  15
  16 use POSIX;
  17
  18 use strict;
  19 use vars qw($pi);
  20
  21 $pi = 3.14159265358979;
  22
  23 # half a qra to lat long translation
  24 sub _half_qratoll
  25 {
  26         my ($l, $n, $m) = @_;
  27         my $lat = ord($l) - ord('A');
  28         $lat = $lat * 10 + (ord($n) - ord('0'));
  29         $lat = $lat * 24 + (ord($m) - ord('A'));
  30         $lat -= (2160 + 0.5);
  31         $lat = $lat * ($pi/4320);
  32
  33 }
  34 # convert a qra locator into lat/long in DEGREES
  35 sub qratoll
  36 {
  37         my $qra = uc shift;
  38         my $long = _half_qratoll((unpack 'AAAAAA', $qra)[0,2,4]) * 2;
  39         my $lat = _half_qratoll((unpack 'AAAAAA', $qra)[1,3,5]);
  40         return (rd($lat), rd($long));
  41 }
  42
  43 sub _part_lltoqra
  44 {
  45         my ($t, $f, $n, $e) = @_;
  46         $n = $f * ($n - int($n));
  47         $e = $f * ($e - int($e));
  48         my $q = chr($t+$e) . chr($t+$n);
  49         return ($q, $n, $e);
  50 }
  51
  52 # convert a lat, long in DEGREES to a qra locator
  53 sub lltoqra
  54 {
  55         my $lat = dr(shift);
  56         my $long = dr(shift);
  57         my $t = 1/6.283185;
  58
  59         $long = $long * $t +.5 ;
  60         $lat = $lat * $t * 2 + .5 ;
  61
  62         my $q;
  63         my $qq;
  64         ($q, $lat, $long) = _part_lltoqra(ord('A'), 18, $lat, $long);
  65         $qq = $q;
  66         ($q, $lat, $long) = _part_lltoqra(ord('0'), 10, $lat, $long);
  67         $qq .= $q;
  68         ($q, $lat, $long) = _part_lltoqra(ord('A'), 24, $lat, $long);
  69         $qq .= $q;
  70         return $qq;
  71 }
  72
  73 # radians to degrees
  74 sub rd
  75 {
  76         my $n = shift;
  77         return ($n / $pi) * 180;
  78 }
  79
  80 # degrees to radians
  81 sub dr
  82 {
  83         my $n = shift;
  84         return ($n / 180) * $pi;
  85 }
  86
  87 # does it look like a qra locator?
  88 sub is_qra
  89 {
  90         my $qra = shift;
  91         return $qra =~ /^[A-Za-z][A-Za-z]\d\d[A-Za-z][A-Za-z]$/o;
  92 }
  93
  94 # calc bearing and distance, with arguments in DEGREES
  95 # home lat/long -> lat/long
  96 # returns bearing (in DEGREES) & distance in KM
  97 sub bdist
  98 {
  99         my $hn = dr(shift);
 100         my $he = dr(shift);
 101         my $n = dr(shift);
 102         my $e = dr(shift);
 103         my $co = cos($he-$e)*cos($hn)*cos($n)+sin($hn)*sin($n);
 104         my $ca = atan(abs(sqrt(1-$co*$co)/$co));
 105         $ca = $pi-$ca if $co < 0;
 106         my $dx = 6367*$ca;
 107         my $si = sin($e-$he)*cos($n)*cos($hn);
 108         $co = sin($n)-sin($hn)*cos($ca);
 109         my $az = atan(abs($si/$co));
 110         $az = $pi - $az if $co < 0;
 111         $az = -$az if $si < 0;
 112         $az = $az+2*$pi if $az < 0;
 113         return (rd($az), $dx);
 114 }
 115
 116 # turn a lat long string into floating point lat and long
 117 sub stoll
 118 {
 119         my ($latd, $latm, $latl, $longd, $longm, $longl) = split /\s+/, shift;
 120
 121         $longd += ($longm/60);
 122         $longd = 0-$longd if (uc $longl) eq 'W';
 123         $latd += ($latm/60);
 124         $latd = 0-$latd if (uc $latl) eq 'S';
 125         return ($latd, $longd);
 126 }
 127
 128 # turn a lat and long into a string
 129 sub lltos
 130 {
 131         my ($lat, $long) = @_;
 132         my ($latd, $latm, $longd, $longm);
 133         my $latl = $lat > 0 ? 'N' : 'S';
 134         my $longl = $long > 0 ? 'E' : 'W';
 135
 136         $lat = abs $lat;
 137         $latd = int $lat;
 138         $lat -= $latd;
 139         $latm = int (60 * $lat);
 140
 141         $long = abs $long;
 142         $longd = int $long;
 143         $long -= $longd;
 144         $longm = int (60 * $long);
 145         return "$latd $latm $latl $longd $longm $longl";
 146 }
 147 1;