File Coverage

blib/lib/Astro/FITS/HdrTrans/ACSIS.pm
Criterion Covered Total %
statement 190 272 69.8
branch 45 148 30.4
condition 39 111 35.1
subroutine 31 31 100.0
pod 19 19 100.0
total 324 581 55.7


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