File Coverage

blib/lib/Astro/FITS/HdrTrans/ACSIS.pm
Criterion Covered Total %
statement 186 268 69.4
branch 45 148 30.4
condition 43 123 34.9
subroutine 30 30 100.0
pod 19 19 100.0
total 323 588 54.9


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