File Coverage

blib/lib/Astro/FITS/HdrTrans/ACSIS.pm
Criterion Covered Total %
statement 188 269 69.8
branch 43 144 29.8
condition 38 108 35.1
subroutine 31 31 100.0
pod 19 19 100.0
total 319 571 55.8


line stmt bran cond sub pod time code
1             package Astro::FITS::HdrTrans::ACSIS;
2              
3             =head1 NAME
4              
5             Astro::FITS::HdrTrans::ACSIS - class for translation of JCMT ACSIS headers
6              
7             =head1 SYNOPSIS
8              
9             use Astro::FITS::HdrTrans::ACSIS;
10              
11             =head1 DESCRIPTION
12              
13             This class provides a set of translations for ACSIS at JCMT.
14              
15             =cut
16              
17 10     10   26695539 use 5.006;
  10         40  
18 10     10   72 use warnings;
  10         27  
  10         368  
19 10     10   53 use strict;
  10         21  
  10         252  
20 10     10   64 use Carp;
  10         19  
  10         810  
21              
22 10     10   7978 use Astro::Coords;
  10         5851352  
  10         365  
23 10     10   6832 use Astro::Telescope;
  10         48555  
  10         363  
24 10     10   89 use DateTime;
  10         24  
  10         228  
25 10     10   108 use DateTime::TimeZone;
  10         24  
  10         282  
26              
27             # inherit from the Base translation class and not HdrTrans
28             # itself (which is just a class-less wrapper)
29 10     10   52 use base qw/ Astro::FITS::HdrTrans::JCMT /;
  10         22  
  10         6473  
30              
31             # Use the FITS standard DATE-OBS handling
32             #use Astro::FITS::HdrTrans::FITS;
33              
34             # Speed of light in km/s.
35 10     10   81 use constant CLIGHT => 2.99792458e5;
  10         24  
  10         635  
36              
37 10     10   59 use vars qw/ $VERSION /;
  10         26  
  10         32222  
38              
39             $VERSION = "1.63";
40              
41             # Cache UTC definition
42             our $UTC = DateTime::TimeZone->new( name => 'UTC' );
43              
44             # in each class we have three sets of data.
45             # - constant mappings
46             # - unit mappings
47             # - complex mappings
48              
49             # for a constant mapping, there is no FITS header, just a generic
50             # header that is constant
51             my %CONST_MAP = (
52             INST_DHS => 'ACSIS',
53             );
54              
55             # unit mapping implies that the value propagates directly
56             # to the output with only a keyword name change
57              
58             my %UNIT_MAP = (
59             AIRMASS_END => 'AMEND',
60             AMBIENT_TEMPERATURE=> 'ATSTART',
61             AZIMUTH_END => 'AZEND',
62             BACKEND => 'BACKEND',
63             BANDWIDTH_MODE => 'BWMODE',
64             CHOP_ANGLE => 'CHOP_PA',
65             CHOP_COORDINATE_SYSTEM => 'CHOP_CRD',
66             CHOP_FREQUENCY => 'CHOP_FRQ',
67             CHOP_THROW => 'CHOP_THR',
68             ELEVATION_END => 'ELEND',
69             FRONTEND => 'INSTRUME',
70             NUMBER_OF_CYCLES => 'NUM_CYC',
71             SWITCH_MODE => 'SW_MODE',
72             SPECIES => 'MOLECULE',
73             VELOCITY_TYPE => 'DOPPLER',
74             );
75              
76             # Create the translation methods
77             __PACKAGE__->_generate_lookup_methods( \%CONST_MAP, \%UNIT_MAP );
78              
79             =head1 METHODS
80              
81             =over 4
82              
83             =item B<can_translate>
84              
85             Returns true if the supplied headers can be handled by this class.
86              
87             $cando = $class->can_translate( \%hdrs );
88              
89             For this class, the method will return true if the B<BACKEND> header exists
90             and matches 'ACSIS'.
91              
92             Can also match translated GSD files.
93              
94             =cut
95              
96             sub can_translate {
97 21     21 1 62 my $self = shift;
98 21         52 my $headers = shift;
99              
100 21 100 66     200 if ( exists $headers->{BACKEND} &&
    50 100        
    50 66        
      66        
      33        
      33        
      33        
      33        
101             defined $headers->{BACKEND} &&
102             $headers->{BACKEND} =~ /^ACSIS/i
103             ) {
104 2         214 return 1;
105              
106             # BACKEND will discriminate between DAS files converted to ACSIS format
107             # from GSD format directly (handled by Astro::FITS::HdrTrans::JCMT_GSD).
108             } elsif ( exists $headers->{BACKEND} &&
109             defined $headers->{BACKEND} &&
110             $headers->{BACKEND} =~ /^DAS/i &&
111             ! (exists $headers->{'GSDFILE'} && exists $headers->{'SCA#'})) {
112             # Do not want to confuse with reverse conversion
113             # of JCMT_GSD data headers which will have a defined
114             # BACKEND header of DAS.
115 0         0 return 1;
116             } elsif ( exists $headers->{INST_DHS} &&
117             defined $headers->{INST_DHS} &&
118             $headers->{INST_DHS} eq 'ACSIS') {
119             # This is for the reverse conversion of DAS data
120 0         0 return 1;
121             } else {
122 19         723 return 0;
123             }
124             }
125              
126             =back
127              
128             =head1 COMPLEX CONVERSIONS
129              
130             These methods are more complicated than a simple mapping. We have to
131             provide both from- and to-FITS conversions All these routines are
132             methods and the to_ routines all take a reference to a hash and return
133             the translated value (a many-to-one mapping) The from_ methods take a
134             reference to a generic hash and return a translated hash (sometimes
135             these are many-to-many)
136              
137             =over 4
138              
139             =item B<to_DR_RECIPE>
140              
141             Usually simply copies the "RECIPE" header. If the observation type is
142             skydip and the RECIPE header is "REDUCE_SCIENCE" we actually use
143             REDUCE_SKYDIP. If a skydip is not being done and the STANDARD header
144             is true, then the recipe is set to REDUCE_STANDARD. If the INBEAM
145             header is "POL", the recipe name has "_POL" appended if it is a
146             science observation. "REDUCE_SCIENCE" is translated to
147             "REDUCE_SCIENCE_GRADIENT".
148              
149             =cut
150              
151             sub to_DR_RECIPE {
152 1     1 1 3 my $class = shift;
153 1         3 my $FITS_headers = shift;
154              
155 1         3 my $dr = $FITS_headers->{RECIPE};
156              
157 1         81 my $obstype = lc( $class->to_OBSERVATION_TYPE( $FITS_headers ) );
158 1         5 my $pol = $class->to_POLARIMETER( $FITS_headers );
159 1         29 my $standard = $class->to_STANDARD( $FITS_headers );
160 1         4 my $utdate = $class->to_UTDATE( $FITS_headers );
161 1         30 my $freq_sw = $class->_is_FSW( $FITS_headers );
162              
163 1 50       8 if ($utdate < 20080701) {
164 1 50 33     4 if ($obstype eq 'skydip' && $dr eq 'REDUCE_SCIENCE') {
165 0         0 $dr = "REDUCE_SKYDIP";
166             }
167             }
168              
169 1         7 my $is_sci = ( $obstype =~ /science|raster|scan|grid|jiggle/ );
170              
171 1 50 33     4 if ( $standard && $is_sci ) {
172 0         0 $dr = "REDUCE_STANDARD";
173             }
174              
175             # Append unless we have already appended
176 1 0 33     4 if ( $utdate > 20081115 && $pol && $is_sci ) {
      33        
177 0 0       0 $dr .= "_POL" unless $dr =~ /_POL$/;
178             }
179 1         2 $dr = uc($dr);
180 1 50       3 if( $dr eq 'REDUCE_SCIENCE' ) {
181 0 0       0 $dr .= '_' . ($freq_sw ? 'FSW' : 'GRADIENT');
182             }
183              
184 1         4 return $dr;
185             }
186              
187             =item B<from_DR_RECIPE>
188              
189             Returns DR_RECIPE unless we have a skydip.
190              
191             =cut
192              
193             sub from_DR_RECIPE {
194 1     1 1 3 my $class = shift;
195 1         2 my $generic_headers = shift;
196 1         3 my $dr = $generic_headers->{DR_RECIPE};
197 1         3 my $ut = $generic_headers->{UTDATE};
198 1 50 33     6 if (defined $ut && $ut < 20080615) {
199 1 50 33     12 if (defined $dr && $dr eq 'REDUCE_SKYDIP') {
200 0         0 $dr = 'REDUCE_SCIENCE';
201             }
202             }
203 1         19 return ("RECIPE" => $dr);
204             }
205              
206             =item B<to_POLARIMETER>
207              
208             If the polarimeter is in the beam, as denoted by the INBEAM header
209             containing "POL", then this returns true. Otherwise, return false.
210              
211             =cut
212              
213             sub to_POLARIMETER {
214 2     2 1 3 my $class = shift;
215 2         4 my $FITS_headers = shift;
216              
217 2         7 my $inbeam = $FITS_headers->{INBEAM};
218 2         87 my $utdate = $class->to_UTDATE( $FITS_headers );
219              
220 2 0 33     69 if ( $utdate > 20081115 &&
      33        
221             defined( $inbeam ) &&
222             $inbeam =~ /pol/i ) {
223 0         0 return 1;
224             }
225 2         5 return 0;
226             }
227              
228             =item B<from_POLARIMETER>
229              
230             If the POLARIMETER header is true, then return "POL" for the INBEAM
231             header. Otherwise, return undef.
232              
233             =cut
234              
235             sub from_POLARIMETER {
236 1     1 1 2 my $class = shift;
237 1         2 my $generic_headers = shift;
238              
239 1         3 my $pol = $generic_headers->{POLARIMETER};
240              
241 1 50       3 if ( $pol ) {
242 0         0 return ( "INBEAM" => "POL" );
243             }
244              
245 1         10 return ( "INBEAM" => undef );
246             }
247              
248             =item B<to_REFERENCE_LOCATION>
249              
250             Creates a string representing the location of the reference spectrum
251             to the nearest hundredth of a degree. It takes the form
252             system_longitude_latitude where system will normally be J2000 or GAL.
253             If the string cannot be evaluated (such as missing headers), the
254             returned value is undefined.
255              
256             =cut
257              
258             sub to_REFERENCE_LOCATION {
259 1     1 1 3 my $self = shift;
260 1         3 my $FITS_headers = shift;
261              
262             # Set the returned value in case something goes awry.
263 1         2 my $ref_location = undef;
264              
265             # Assume that the co-ordinate system is the same for the BASE
266             # co-ordinates as the offset to the reference spectrum.
267 1         3 my ( $system, $base_lon, $base_lat );
268              
269             $system = defined( $FITS_headers->{'TRACKSYS'} ) ?
270 1 50       4 $FITS_headers->{'TRACKSYS'} :
271             undef;
272 1 50       51 $system =~ s/\s+$// if defined( $system );
273              
274             # Obtain the base location's longitude in decimal degrees.
275             $base_lon = defined( $FITS_headers->{'BASEC1'} ) ?
276 1 50       4 $FITS_headers->{'BASEC1'} :
277             undef;
278              
279             # Obtain the base location's latitude in decimal degrees.
280             $base_lat = defined( $FITS_headers->{'BASEC2'} ) ?
281 1 50       43 $FITS_headers->{'BASEC2'} :
282             undef;
283              
284             # Derive the reference position's longitude.
285 1         39 my $ref_lon = undef;
286 1 50 33     16 if ( defined( $system ) && defined( $base_lon ) ) {
287              
288             # The value of SKYREFX has the form
289             # [OFFSET] <longitude_offset_in_arcsec> [<co-ordinate system>]
290             #
291             # Assume for now that the TRACKSYS and co-ordinate system are the
292             # same.
293 0 0       0 if ( defined( $FITS_headers->{'SKYREFX'} ) ) {
294 0         0 my $ref_x = $FITS_headers->{'SKYREFX'};
295 0         0 my @comps = split( /\s+/, $ref_x );
296 0         0 my $offset_lon = $comps[1] / 3600.0;
297              
298             # Two decimal places should permit sufficient fuzziness.
299 0         0 $ref_lon = sprintf( "%.2f", $base_lon + $offset_lon );
300             }
301             }
302              
303             # Derive the reference position's latitude.
304 1         2 my $ref_lat = undef;
305 1 50 33     4 if ( defined( $system ) && defined( $base_lat ) ) {
306              
307             # The value of SKYREFY has the form
308             # [OFFSET] <latitude_offset_in_arcsec> [<co-ordinate system>]
309             #
310             # Assume for now that the TRACKSYS and co-ordinate system are the
311             # same.
312 0 0       0 if ( defined( $FITS_headers->{'SKYREFY'} ) ) {
313 0         0 my $ref_y = $FITS_headers->{'SKYREFY'};
314 0         0 my @comps = split( /\s+/, $ref_y );
315 0         0 my $offset_lat = $comps[1] / 3600.0;
316 0         0 $ref_lat = sprintf( "%.2f", $base_lat + $offset_lat );
317             }
318             }
319              
320             # Form the string comprising the three elements.
321 1 50 33     4 if ( defined( $ref_lon ) && defined( $ref_lat ) ) {
322 0         0 $ref_location = $system . "_" . $ref_lon . "_" . $ref_lat;
323             }
324              
325 1         3 return $ref_location;
326             }
327              
328              
329             =item B<to_SAMPLE_MODE>
330              
331             If the SAM_MODE value is either 'raster' or 'scan', return
332             'scan'. Otherwise, return the value in lowercase.
333              
334             =cut
335              
336             sub to_SAMPLE_MODE {
337 1     1 1 3 my $self = shift;
338 1         2 my $FITS_headers = shift;
339              
340 1         2 my $sam_mode;
341 1 50 33     3 if( defined( $FITS_headers->{'SAM_MODE'} ) &&
342             uc( $FITS_headers->{'SAM_MODE'} ) eq 'RASTER' ) {
343 0         0 $sam_mode = 'scan';
344             } else {
345 1         119 $sam_mode = lc( $FITS_headers->{'SAM_MODE'} );
346             }
347 1         57 return $sam_mode;
348             }
349              
350             =item B<to_SURVEY>
351              
352             Checks the value of the SURVEY header and uses that. If it's
353             undefined, then use the PROJECT header to determine an appropriate
354             survey.
355              
356             =cut
357              
358             sub to_SURVEY {
359 1     1 1 2 my $self = shift;
360 1         2 my $FITS_headers = shift;
361              
362 1         2 my $survey;
363              
364 1 50       4 if( defined( $FITS_headers->{'SURVEY'} ) ) {
365 0         0 $survey = $FITS_headers->{'SURVEY'};
366             } else {
367              
368 1         58 my $project = $FITS_headers->{'PROJECT'};
369 1 50       56 if( defined( $project ) ) {
370 1 50       4 if( $project =~ /JLS([GNS])/ ) {
371 0 0       0 if( $1 eq 'G' ) {
    0          
    0          
372 0         0 $survey = 'GBS';
373             } elsif( $1 eq 'N' ) {
374 0         0 $survey = 'NGS';
375             } elsif( $1 eq 'S' ) {
376 0         0 $survey = 'SLS';
377             }
378             }
379             }
380             }
381              
382 1         3 return $survey;
383              
384             }
385              
386             =item B<to_EXPOSURE_TIME>
387              
388             Uses the to_UTSTART and to_UTEND functions to calculate the exposure
389             time. Returns the exposure time as a scalar, not as a Time::Seconds
390             object.
391              
392             =cut
393              
394             sub to_EXPOSURE_TIME {
395 1     1 1 5 my $self = shift;
396 1         4 my $FITS_headers = shift;
397              
398             # force date headers to be standardized
399 1         4 $self->_fix_dates( $FITS_headers );
400              
401 1         7 my $return;
402 1 50 33     7 if ( exists( $FITS_headers->{'DATE-OBS'} ) &&
403             exists( $FITS_headers->{'DATE-END'} ) ) {
404 1         50 my $start = $self->to_UTSTART( $FITS_headers );
405 1         9 my $end = $self->to_UTEND( $FITS_headers );
406 1         15 my $duration = $end - $start;
407 1         38 $return = $duration->seconds;
408             }
409 1         41 return $return;
410             }
411              
412             =item B<to_INSTRUMENT>
413              
414             Converts the C<INSTRUME> header into the C<INSTRUMENT> header. If the
415             C<INSTRUME> header begins with "HARP" or "FE_HARP", then the
416             C<INSTRUMENT> header will be set to "HARP".
417              
418             =cut
419              
420             sub to_INSTRUMENT {
421 1     1 1 40 my $self = shift;
422 1         3 my $FITS_headers = shift;
423 1         2 my $return;
424 1 50       6 if ( exists( $FITS_headers->{'INSTRUME'} ) ) {
425 1 50 33     29 if ( $FITS_headers->{'INSTRUME'} =~ /^HARP/ ||
426             $FITS_headers->{'INSTRUME'} =~ /^FE_HARP/ ) {
427 0         0 $return = "HARP";
428             } else {
429 1         132 $return = $FITS_headers->{'INSTRUME'};
430             }
431             }
432 1         56 return $return;
433             }
434              
435             =item B<to_OBSERVATION_ID>
436              
437             Converts the C<OBSID> header directly into the C<OBSERVATION_ID>
438             generic header, or if that header does not exist, converts the
439             C<BACKEND>, C<OBSNUM>, and C<DATE-OBS> headers into C<OBSERVATION_ID>.
440              
441             =cut
442              
443             sub to_OBSERVATION_ID {
444 1     1 1 3 my $self = shift;
445 1         2 my $FITS_headers = shift;
446 1         3 my $return;
447 1 50 33     4 if ( exists( $FITS_headers->{'OBSID'} ) &&
448             defined( $FITS_headers->{'OBSID'} ) ) {
449 1         80 $return = $FITS_headers->{'OBSID'};
450             } else {
451 0         0 $self->_fix_dates( $FITS_headers );
452              
453 0         0 my $backend = lc( $self->to_BACKEND( $FITS_headers ) );
454 0         0 my $obsnum = $self->to_OBSERVATION_NUMBER( $FITS_headers );
455 0         0 my $dateobs = $self->to_UTSTART( $FITS_headers );
456              
457 0 0 0     0 if ( defined( $backend ) &&
      0        
458             defined( $obsnum ) &&
459             defined( $dateobs ) ) {
460 0         0 my $datetime = $dateobs->datetime;
461 0         0 $datetime =~ s/-//g;
462 0         0 $datetime =~ s/://g;
463              
464 0         0 $return = join '_', $backend, $obsnum, $datetime;
465             }
466             }
467              
468 1         52 return $return;
469             }
470              
471             =item B<to_OBSERVATION_MODE>
472              
473             Concatenates the SAM_MODE, SW_MODE, and OBS_TYPE header keywords into
474             the OBSERVATION_MODE generic header, with spaces removed and joined
475             with underscores. For example, if SAM_MODE is 'jiggle ', SW_MODE is
476             'chop ', and OBS_TYPE is 'science ', then the OBSERVATION_MODE generic
477             header will be 'jiggle_chop_science'.
478              
479             =cut
480              
481             sub to_OBSERVATION_MODE {
482 1     1 1 4 my $self = shift;
483 1         2 my $FITS_headers = shift;
484              
485 1         2 my $return;
486 1 50 33     6 if ( exists( $FITS_headers->{'SAM_MODE'} ) &&
      33        
487             exists( $FITS_headers->{'SW_MODE'} ) &&
488             exists( $FITS_headers->{'OBS_TYPE'} ) ) {
489 1         67 my $sam_mode = $FITS_headers->{'SAM_MODE'};
490 1         62 $sam_mode =~ s/\s//g;
491 1 50       5 $sam_mode = "raster" if $sam_mode eq "scan";
492 1         4 my $sw_mode = $FITS_headers->{'SW_MODE'};
493 1         54 $sw_mode =~ s/\s//g;
494              
495             # handle OBS_TYPE missing
496 1         4 my $obs_type = $FITS_headers->{'OBS_TYPE'};
497 1 50       55 $obs_type = "science" unless $obs_type;
498 1         3 $obs_type =~ s/\s//g;
499              
500 1 50       6 $return = ( ( $obs_type =~ /science/i )
501             ? join '_', $sam_mode, $sw_mode
502             : join '_', $sam_mode, $sw_mode, $obs_type );
503             }
504 1         3 return $return;
505             }
506              
507             =item B<to_OBSERVATION_TYPE>
508              
509             Returns the type of observation that was done. If the OBS_TYPE header
510             matches /science/, the SAM_MODE header is used: if SAM_MODE matches
511             /raster/, then return 'raster'. If SAM_MODE matches /grid/, then
512             return 'grid'. If SAM_MODE matches /jiggle/, then return 'jiggle'.
513              
514             If the OBS_TYPE header matches /focus/, then return 'focus'. If the
515             OBS_TYPE header matches /pointing/, then return 'pointing'.
516              
517             If none of the above options hold, then return undef.
518              
519             =cut
520              
521             sub to_OBSERVATION_TYPE {
522 2     2 1 4 my $self = shift;
523 2         4 my $FITS_headers = shift;
524              
525 2         2 my $return;
526 2         5 my $ot = $FITS_headers->{OBS_TYPE};
527              
528             # Sometimes we lack OBS_TYPE. In that case we have to assume SCIENCE
529             # even though the headers are broken. (eg 20080509#18 RxWD)
530 2 50       120 $ot = "science" unless $ot;
531              
532 2 50       4 if ( $ot ) {
533 2         4 my $obs_type = lc( $ot );
534              
535 2 50       10 if ( $obs_type =~ /science/ ) {
    50          
    0          
    0          
536              
537 0 0       0 if ( defined( $FITS_headers->{'SAM_MODE'} ) ) {
538              
539 0         0 my $sam_mode = $FITS_headers->{'SAM_MODE'};
540              
541 0 0       0 if ( $sam_mode =~ /raster|scan/ ) {
    0          
    0          
542 0         0 $return = "raster";
543             } elsif ( $sam_mode =~ /grid/ ) {
544 0         0 $return = "grid";
545             } elsif ( $sam_mode =~ /jiggle/ ) {
546 0         0 $return = "jiggle";
547             } else {
548 0         0 croak "Unexpected sample mode: '$sam_mode'";
549             }
550             }
551             } elsif ( $obs_type =~ /focus/ ) {
552 2         5 $return = "focus";
553             } elsif ( $obs_type =~ /pointing/ ) {
554 0         0 $return = "pointing";
555             } elsif ( $obs_type =~ /skydip/) {
556 0         0 $return = "skydip";
557             } else {
558 0         0 croak "Unexpected OBS_TYPE of '$obs_type'\n";
559             }
560             }
561              
562 2         5 return $return;
563             }
564              
565              
566             =item B<to_REST_FREQUENCY>
567              
568             Uses an C<Starlink::AST::FrameSet> object to determine the
569             frequency. If such an object is not passed in, then the rest frequency
570             is set to zero.
571              
572             Returns the rest frequency in Hz.
573              
574             =cut
575              
576             sub to_REST_FREQUENCY {
577 1     1 1 3 my $self = shift;
578 1         2 my $FITS_headers = shift;
579 1         1 my $frameset = shift;
580              
581 1         2 my $return;
582              
583 1 50 33     6 if ( defined( $frameset ) &&
    50 33        
      33        
584             UNIVERSAL::isa( $frameset, "Starlink::AST::FrameSet" ) ) {
585             # in some rare cases restfreq is not set in the frameset
586 0         0 eval {
587 0         0 my $frequency = $frameset->Get( "restfreq" );
588 0         0 $return = $frequency * 1_000_000_000;
589             };
590             } elsif ( exists( $FITS_headers->{'RESTFREQ'} ) ||
591             ( exists( $FITS_headers->{'SUBHEADERS'} ) &&
592             exists( $FITS_headers->{'SUBHEADERS'}->[0]->{'RESTFREQ'} ) ) ) {
593              
594             $return = exists( $FITS_headers->{'RESTFREQ'} ) ?
595             $FITS_headers->{'RESTFREQ'} :
596 0 0       0 $FITS_headers->{'SUBHEADERS'}->[0]->{'RESTFREQ'};
597 0         0 $return *= 1_000_000_000;
598             }
599              
600 1         74 return $return;
601             }
602              
603             =item B<to_SYSTEM_VELOCITY>
604              
605             Converts the DOPPLER and SPECSYS headers into one combined
606             SYSTEM_VELOCITY header. The first three characters of each specific
607             header are used and concatenated. For example, if DOPPLER is 'radio'
608             and SPECSYS is 'LSR', then the resulting SYSTEM_VELOCITY generic
609             header will be 'RADLSR'. The results are always returned in capital
610             letters.
611              
612             =cut
613              
614             sub to_SYSTEM_VELOCITY {
615 1     1 1 3 my $self = shift;
616 1         3 my $FITS_headers = shift;
617 1         2 my $frameset = shift;
618              
619 1         1 my $return;
620 1 50 33     5 if ( exists( $FITS_headers->{'DOPPLER'} ) && defined $FITS_headers->{DOPPLER} ) {
621 0         0 my $doppler = uc( $FITS_headers->{'DOPPLER'} );
622              
623 0 0 0     0 if ( defined( $frameset ) &&
624             UNIVERSAL::isa( $frameset, "Starlink::AST::FrameSet" ) ) {
625             # Sometimes we have frequency axis (rare)
626 0         0 eval {
627 0         0 my $sourcevrf = uc( $frameset->Get( "sourcevrf" ) );
628 0         0 $return = substr( $doppler, 0, 3 ) . substr( $sourcevrf, 0, 3 );
629             };
630             }
631 0 0       0 if (!defined $return) {
632 0 0       0 if ( exists( $FITS_headers->{'SPECSYS'} ) ) {
633 0         0 my $specsys = uc( $FITS_headers->{'SPECSYS'} );
634 0         0 $return = substr( $doppler, 0, 3 ) . substr( $specsys, 0, 3 );
635             } else {
636 0         0 my $specsys = '';
637 0 0       0 if ( $doppler eq 'RADIO' ) {
    0          
638 0         0 $specsys = 'LSRK';
639             } elsif ( $doppler eq 'OPTICAL' ) {
640 0         0 $specsys = 'HELIOCENTRIC';
641             }
642 0         0 $return = substr( $doppler, 0, 3 ) . substr( $specsys, 0, 3 );
643             }
644             }
645             }
646 1         84 return $return;
647             }
648              
649             =item B<to_TRANSITION>
650              
651             Converts the TRANSITI header to the TRANSITION generic header.
652              
653             This would be a unit mapping except that we would like to tidy up
654             some whitespace issues.
655              
656             =cut
657              
658             sub to_TRANSITION {
659 1     1 1 4 my $self = shift;
660 1         2 my $FITS_headers = shift;
661              
662 1         4 my $transition = $FITS_headers->{'TRANSITI'};
663              
664 1 50       70 return undef unless defined $transition;
665              
666             # Remove leading and trailing spaces.
667 1         6 $transition =~ s/^ *//;
668 1         5 $transition =~ s/ *$//;
669             # Remove duplicated spaces.
670 1         4 $transition =~ s/ +/ /g;
671              
672 1         3 return $transition;
673             }
674              
675             =item B<from_TRANSITION>
676              
677             Converts TRANSITION back to TRANSITI.
678              
679             =cut
680              
681             sub from_TRANSITION {
682 1     1 1 2 my $self = shift;
683 1         3 my $generic_headers = shift;
684              
685 1         3 my $transition = $generic_headers->{'TRANSITION'};
686              
687 1 50       5 if (defined $transition) {
688             # Restore whitespace issue to allow comparison of untranslated header.
689 1         5 $transition =~ s/ - / - /;
690             }
691              
692 1         15 return (TRANSITI => $transition);
693             }
694              
695             =item B<to_VELOCITY>
696              
697             Converts the ZSOURCE header into an appropriate system velocity,
698             depending on the value of the DOPPLER header. If the DOPPLER header is
699             'redshift', then the VELOCITY generic header will be returned
700             as a redshift. If the DOPPLER header is 'optical', then the
701             VELOCITY generic header will be returned as an optical
702             velocity. If the DOPPLER header is 'radio', then the VELOCITY
703             generic header will be returned as a radio velocity. Note that
704             calculating the radio velocity from the zeropoint (which is the
705             ZSOURCE header) gives accurates results only if the radio velocity is
706             a small fraction (~0.01) of the speed of light.
707              
708             =cut
709              
710             sub to_VELOCITY {
711 1     1 1 2 my $self = shift;
712 1         3 my $FITS_headers = shift;
713 1         2 my $frameset = shift;
714              
715 1         2 my $velocity = 0;
716 1 50 33     5 if ( defined( $frameset ) &&
717             UNIVERSAL::isa( $frameset, "Starlink::AST::FrameSet" ) ) {
718              
719 0         0 my $sourcesys = "VRAD";
720 0 0       0 if ( defined( $FITS_headers->{'DOPPLER'} ) ) {
721 0 0       0 if ( $FITS_headers->{'DOPPLER'} =~ /rad/i ) {
    0          
    0          
722 0         0 $sourcesys = "VRAD";
723             } elsif ( $FITS_headers->{'DOPPLER'} =~ /opt/i ) {
724 0         0 $sourcesys = "VOPT";
725             } elsif ( $FITS_headers->{'DOPPLER'} =~ /red/i ) {
726 0         0 $sourcesys = "REDSHIFT";
727             }
728             }
729             # Sometimes we do not have a spec frame (broken files)
730 0         0 eval {
731 0         0 $frameset->Set( sourcesys => $sourcesys );
732 0         0 $velocity = $frameset->Get( "sourcevel" );
733             };
734             } else {
735              
736             # We weren't passed a frameset, so try using other headers.
737 1 50 33     3 if ( exists( $FITS_headers->{'DOPPLER'} ) &&
      33        
738             ( exists( $FITS_headers->{'ZSOURCE'} ) ||
739             exists( $FITS_headers->{'SUBHEADERS'}->[0]->{'ZSOURCE'} ) ) ) {
740 0         0 my $doppler = uc( $FITS_headers->{'DOPPLER'} );
741             my $zsource = exists( $FITS_headers->{'ZSOURCE'} ) ?
742             $FITS_headers->{'ZSOURCE'} :
743 0 0       0 $FITS_headers->{'SUBHEADERS'}->[0]->{'ZSOURCE'};
744              
745 0 0       0 if ( $doppler eq 'REDSHIFT' ) {
    0          
    0          
746 0         0 $velocity = $zsource;
747             } elsif ( $doppler eq 'OPTICAL' ) {
748 0         0 $velocity = $zsource * CLIGHT;
749             } elsif ( $doppler eq 'RADIO' ) {
750 0         0 $velocity = ( CLIGHT * $zsource ) / ( 1 + $zsource );
751             }
752             }
753             }
754              
755 1         82 return $velocity;
756             }
757              
758             =item B<to_SUBSYSTEM_IDKEY>
759              
760             =cut
761              
762             sub to_SUBSYSTEM_IDKEY {
763 1     1 1 4 my $self = shift;
764 1         3 my $FITS_headers = shift;
765              
766             # Try the general headers first
767 1         7 my $general = $self->SUPER::to_SUBSYSTEM_IDKEY( $FITS_headers );
768 1 50       7 return ( defined $general ? $general : "SUBSYSNR" );
769             }
770              
771              
772             =item B<_is_FSW>
773              
774             Helper function to determine if we are doing frequency switch.
775              
776             =cut
777              
778             sub _is_FSW {
779 1     1   3 my $class = shift;
780 1         2 my $FITS_headers = shift;
781              
782 1         4 my $fsw = $FITS_headers->{SW_MODE};
783              
784 1 50 33     67 if ( defined( $fsw ) &&
785             $fsw =~ /freqsw/i ) {
786 0         0 return 1;
787             }
788 1         7 return 0;
789             }
790              
791             =back
792              
793             =head1 SEE ALSO
794              
795             C<Astro::FITS::HdrTrans>, C<Astro::FITS::HdrTrans::Base>
796              
797             =head1 AUTHORS
798              
799             Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt>,
800             Brad Cavanagh E<lt>b.cavanagh@jach.hawaii.eduE<gt>.
801              
802             =head1 COPYRIGHT
803              
804             Copyright (C) 2016 East Asian Observatory.
805             Copyright (C) 2007-2013, 2016 Science and Technology Facilities Council.
806             Copyright (C) 2005-2007 Particle Physics and Astronomy Research Council.
807             All Rights Reserved.
808              
809             This program is free software; you can redistribute it and/or modify it under
810             the terms of the GNU General Public License as published by the Free Software
811             Foundation; either version 2 of the License, or (at your option) any later
812             version.
813              
814             This program is distributed in the hope that it will be useful,but WITHOUT ANY
815             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
816             PARTICULAR PURPOSE. See the GNU General Public License for more details.
817              
818             You should have received a copy of the GNU General Public License along with
819             this program; if not, write to the Free Software Foundation, Inc., 59 Temple
820             Place,Suite 330, Boston, MA 02111-1307, USA
821              
822             =cut
823              
824             1;