1#!/usr/bin/perl 2use strict; 3 4use blib; 5use Astro::FITS::CFITSIO qw( :longnames :constants ); 6 7my $oskey='value_string'; 8my $olkey=1; 9my $ojkey=11; 10my $otint = 12345678; 11my $ofkey = 12.121212; 12my $oekey = 13.131313; 13my $ogkey = 14.1414141414141414; 14my $odkey = 15.1515151515151515; 15my $otfrac = 0.1234567890123456; 16my $xcoordtype = 'RA---TAN'; 17my $ycoordtype = 'DEC--TAN'; 18my $onskey = [ 'first string', 'second string', ' ' ]; 19my $inclist = [ 'key*', 'newikys' ]; 20my $exclist = [ 'key_pr*', 'key_pkls' ]; 21my $onlkey = [1,0,1]; 22my $onjkey = [11,12,13]; 23my $onfkey = [12.121212, 13.131313, 14.141414]; 24my $onekey = [13.131313, 14.141414, 15.151515]; 25my $ongkey = [14.1414141414141414, 15.1515151515151515,16.1616161616161616]; 26my $ondkey = [15.1515151515151515, 16.1616161616161616,17.1717171717171717]; 27my $tbcol = [1,17,28,43,56]; 28my $binname = "Test-BINTABLE"; 29my $template = "testprog.tpt"; 30my $tblname = "Test-ASCII"; 31my ($status,$tmp,$tmp1,$tmp2,@tmp); 32my ($ttype,$tunit,$tdisp,$tform,$nrows,$tfields,$morekeys,$extvers,$koutarray); 33my ($colnum,$colname,$typecode,$repeat,$width,$scale,$zero,$jnulval,$hdutype); 34my ($rowlen,$errmsg,$nmsg,$cval,$oshtkey); 35 36my ($version,$fptr,$tmpfptr); 37my ($filename,$filemode); 38my ($simple,$bitpix,$naxis,$naxes,$npixels,$pcount,$gcount,$extend); 39my ($card,$card2,$comment,$comm); 40my ($nkeys); 41my ($boutarray,$ioutarray,$joutarray,$eoutarray,$doutarray); 42my ($hdunum,$anynull); 43my ($binarray,$iinarray,$jinarray,$einarray,$dinarray); 44my ($ii,$jj,$larray,$larray2,$imgarray,$imgarray2); 45my ($keyword,$value); 46my ($iskey,$ilkey,$ijkey,$iekey,$idkey,$ishtkey,$inekey,$indkey); 47my $lsptr; 48my ($existkeys,$keynum); 49my ($inskey,$nfound,$inlkey,$injkey); 50my ($signval,$uchars,$nulstr); 51my ($xinarray,$kinarray,$cinarray,$minarray); 52my ($lpixels,$fpixels,$inc,$offset); 53my ($bnul,$inul,$knul,$jnul,$enul,$dnul); 54my ($xrval,$yrval,$xrpix,$yrpix,$xinc,$yinc,$rot,$ctype,$xpix,$ypix,$xpos,$ypos); 55my ($checksum,$asciisum,$datsum,$datastatus,$hdustatus); 56 57fits_get_version($version); 58 59printf "CFITSIO TESTPROG\n\n";#, v%.3f\n\n",$version; 60 61print "Try opening then closing a nonexistent file:\n"; 62$status=0; 63$fptr=Astro::FITS::CFITSIO::open_file('tq123x.kjl',READWRITE,$status); 64printf " ffopen fptr, status = %d %d (expect an error)\n",$fptr,$status; 65eval { 66 $status = 115; # cheat!!! 67 $fptr->close_file($status); 68}; 69printf " ffclos status = %d\n\n", $status; 70fits_clear_errmsg(); 71 72$status=0; 73$fptr=Astro::FITS::CFITSIO::create_file('!testprog.fit',$status); 74print "ffinit create new file status = $status\n"; 75$status and goto ERRSTATUS; 76 77$fptr->file_name($filename,$status); 78$fptr->file_mode($filemode,$status); 79print "Name of file = $filename, I/O mode = $filemode\n"; 80$simple=1; 81$bitpix=32; 82$naxis=2; 83$naxes=[10,2]; 84$npixels=20; 85$pcount=0; 86$gcount=1; 87$extend=1; 88 89############################ 90# write single keywords # 91############################ 92 93$fptr->write_imghdr($bitpix,$naxis,$naxes,$status) and 94 print "ffphps status = $status"; 95 96$fptr->write_record( 97 "key_prec= 'This keyword was written by fxprec' / comment goes here", 98 $status 99) and printf"ffprec status = $status\n"; 100 101print "\ntest writing of long string keywords:\n"; 102$card = 103 "1234567890123456789012345678901234567890" . 104 "12345678901234567890123456789012345"; 105$fptr->write_key_str("card1",$card,"",$status); 106$fptr->read_keyword('card1',$card2,$comment,$status); 107print " $card\n$card2\n"; 108 109$card = 110 "1234567890123456789012345678901234567890" . 111 "123456789012345678901234'6789012345"; 112$fptr->write_key_str('card2',$card,"",$status); 113$fptr->read_keyword('card2',$card2,$comment,$status); 114print " $card\n$card2\n"; 115 116$card = 117 "1234567890123456789012345678901234567890" . 118 "123456789012345678901234''789012345"; 119$fptr->write_key_str('card3',$card,"",$status); 120$fptr->read_keyword('card3',$card2,$comment,$status); 121print " $card\n$card2\n"; 122 123$card = 124 "1234567890123456789012345678901234567890" . 125 "123456789012345678901234567'9012345"; 126$fptr->write_key_str('card4',$card,"",$status); 127$fptr->read_keyword('card4',$card2,$comment,$status); 128print " $card\n$card2\n"; 129 130 131$fptr->write_key_str('key_pkys',$oskey,'fxpkys comment',$status) 132 and print "ffpkys status = $status\n"; 133$fptr->write_key_log('key_pkyl',$olkey,'fxpkyl comment',$status) 134 and print "ffpkyl status = $status\n"; 135$fptr->write_key_lng('key_pkyj',$ojkey,'fxpkyj comment',$status) 136 and print "ffpkyj status = $status\n"; 137$fptr->write_key_fixflt('key_pkyf',$ofkey,5,'fxpkyf comment',$status) 138 and print "ffpkyf status = $status\n"; 139$fptr->write_key_flt('key_pkye',$oekey,6,'fxpkye comment',$status) 140 and print "ffpkye status = $status\n"; 141$fptr->write_key_fixdbl('key_pkyg',$ogkey,14,'fxpkyg comment',$status) 142 and print "ffpkyg status = $status\n"; 143$fptr->write_key_dbl('key_pkyd',$odkey,14,'fxpkyd comment',$status) 144 and print "ffpkyd status = $status\n"; 145$fptr->write_key_cmp('key_pkyc',$onekey,6,'fxpkyc comment',$status) 146 and print "ffpkyc status = $status\n"; 147$fptr->write_key_dblcmp('key_pkym',$ondkey,14,'fxpkym comment',$status) 148 and print "ffpkym status = $status\n"; 149$fptr->write_key_fixcmp('key_pkfc',$onekey,6,'fxpkfc comment',$status) 150 and print "ffpkfc status = $status\n"; 151$fptr->write_key_fixdblcmp('key_pkfm',$ondkey,14,'fxpkfm comment',$status) 152 and print "ffpkfm status = $status\n"; 153 154$fptr->write_key_longstr( 155 'key_pkls', 156 'This is a very long string value that is continued over more than one keyword.', 157 'fxpkls comment', 158 $status, 159) and print "ffpkls status = $status\n"; 160$fptr->write_key_longwarn($status) 161 and print "ffplsw status = $status\n"; 162$fptr->write_key_triple('key_pkyt',$otint,$otfrac,'fxpkyt comment',$status) 163 and print "ffpkyt status = $status\n"; 164$fptr->write_comment(' This keyword was written by fxpcom.',$status) 165 and print "ffpcom status = $status\n"; 166$fptr->write_history(" This keyword written by fxphis (w/ 2 leading spaces).",$status) 167 and print "ffphis status = $status\n"; 168$fptr->write_date($status) and print "ffpdat status = $status\n, goto ERRSTATUS"; 169 170############################ 171# write arrays of keywords # 172############################ 173$nkeys = 3; 174 175$fptr->write_keys_str('ky_pkns',1,$nkeys,$onskey,'fxpkns comment&',$status) 176 and print "ffpkns status = $status\n"; 177$fptr->write_keys_log('ky_pknl',1,$nkeys,$onlkey,'fxpknl comment&',$status) 178 and print "ffpknl status = $status\n"; 179$fptr->write_keys_lng('ky_pknj',1,$nkeys,$onjkey,'fxpknj comment&',$status) 180 and print "ffpknj status = $status\n"; 181$fptr->write_keys_fixflt('ky_pknf',1,$nkeys,$onfkey,5,'fxpknf comment&',$status) 182 and print "ffpknf status = $status\n"; 183$fptr->write_keys_flt('ky_pkne',1,$nkeys,$onekey,6,'fxpkne comment&',$status) 184 and print "ffpkne status = $status\n"; 185$fptr->write_keys_fixdbl('ky_pkng',1,$nkeys,$ongkey,13,'fxpkng comment&',$status) 186 and print "ffpkng status = $status\n"; 187$fptr->write_keys_dbl('ky_pknd',1,$nkeys,$ondkey,14,'fxpknd comment&',$status) 188 and print "ffpknd status = $status\n",goto ERRSTATUS; 189 190############################ 191# write generic keywords # 192############################ 193$oskey = 1; 194$fptr->write_key(TSTRING,'tstring',$oskey,'tstring comment',$status) 195 and print "ffpky status = $status\n"; 196$olkey = TLOGICAL; 197$fptr->write_key(TLOGICAL,'tlogical',$olkey,'tlogical comment',$status) 198 and print "ffpky status = $status\n"; 199$cval = TBYTE; 200$fptr->write_key(TBYTE,'tbyte',$cval,'tbyte comment',$status) 201 and print "ffpky status = $status\n"; 202$oshtkey = TSHORT; 203$fptr->write_key(TSHORT,'tshort',$oshtkey,'tshort comment',$status) 204 and print "ffpky status = $status\n"; 205$olkey = TINT; 206$fptr->write_key(TINT,'tint',$olkey,'tint comment',$status) 207 and print "ffpky status = $status\n"; 208$ojkey = TLONG; 209$fptr->write_key(TLONG,'tlong',$ojkey,'tlong comment',$status) 210 and print "ffpky status = $status\n"; 211$oekey = TFLOAT; 212$fptr->write_key(TFLOAT,'tfloat',$oekey,'tfloat comment',$status) 213 and print "ffpky status = $status\n"; 214$odkey = TDOUBLE; 215$fptr->write_key(TDOUBLE,'tdouble',$odkey,'tdouble comment',$status) 216 and print "ffpky status = $status\n"; 217 218 219############################ 220# write data # 221############################ 222 223$fptr->write_key_lng('BLANK',-99,'value to use for undefined pixels',$status) 224 and print "BLANK keyword status = $status\n"; 225 226$boutarray = [1..$npixels]; 227$ioutarray = [1..$npixels]; 228$joutarray = [1..$npixels]; 229$eoutarray = [1..$npixels]; 230$doutarray = [1..$npixels]; 231 232$fptr->write_img_byt(1,1,2,[@{$boutarray}[0..1]],$status); 233$fptr->write_img_sht(1,5,2,[@{$ioutarray}[4..5]],$status); 234$fptr->write_img_lng(1,9,2,[@{$joutarray}[8..9]],$status); 235$fptr->write_img_flt(1,13,2,[@{$eoutarray}[12..13]],$status); 236$fptr->write_img_dbl(1,17,2,[@{$doutarray}[16..17]],$status); 237$fptr->write_imgnull_byt(1,3,2,[@{$boutarray}[2..3]],4,$status); 238$fptr->write_imgnull_sht(1,7,2,[@{$ioutarray}[6..7]],8,$status); 239$fptr->write_imgnull_lng(1,11,2,[@{$joutarray}[10..11]],12,$status); 240$fptr->write_imgnull_flt(1,15,2,[@{$eoutarray}[14..15]],16,$status); 241$fptr->write_imgnull_dbl(1,19,2,[@{$doutarray}[18..19]],20,$status); 242$fptr->write_img_null(1,1,1,$status); 243$status and print "ffppnx status = $status\n", goto ERRSTATUS; 244 245$fptr->flush_file($status); 246print "ffflus status = $status\n"; 247print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 248 249############################ 250# read data # 251############################ 252print "\nValues read back from primary array (99 = null pixel)\n"; 253print "The 1st, and every 4th pixel should be undefined:\n"; 254 255$anynull = 0; 256$fptr->read_img_byt(1,1,10,99,$binarray,$anynull,$status); 257$fptr->read_img_byt(1,11,10,99,$tmp,$anynull,$status); 258@{$binarray}[10..$npixels-1] = @{$tmp}; 259map printf(" %2d",$binarray->[$_]),(0..$npixels-1); 260print " $anynull (ffgpvb)\n"; 261 262$fptr->read_img_sht(1,1,$npixels,99,$iinarray,$anynull,$status); 263map printf(" %2d",$iinarray->[$_]),(0..$npixels-1); 264print " $anynull (ffgpvi)\n"; 265 266$fptr->read_img_lng(1,1,$npixels,99,$jinarray,$anynull,$status); 267map printf(" %2d",$jinarray->[$_]),(0..$npixels-1); 268print " $anynull (ffgpvj)\n"; 269 270$fptr->read_img_flt(1,1,$npixels,99,$einarray,$anynull,$status); 271map printf(" %2.0f",$einarray->[$_]),(0..$npixels-1); 272print " $anynull (ffgpve)\n"; 273 274$fptr->read_img_dbl(1,1,10,99,$dinarray,$anynull,$status); 275$fptr->read_img_dbl(1,11,10,99,$tmp,$anynull,$status); 276@{$dinarray}[10..$npixels-1] = @{$tmp}; 277map printf(" %2.0d",$dinarray->[$_]),(0..$npixels-1); 278print " $anynull (ffgpvd)\n"; 279 280$status and print("ERROR: ffgpv_ status = $status\n"), goto ERRSTATUS; 281$anynull or print "ERROR: ffgpv_ did not detect null values\n"; 282 283for ($ii=3;$ii<$npixels;$ii+=4) { 284 $boutarray->[$ii] = 99; 285 $ioutarray->[$ii] = 99; 286 $joutarray->[$ii] = 99; 287 $eoutarray->[$ii] = 99.; 288 $doutarray->[$ii] = 99.; 289} 290$ii=0; 291$boutarray->[$ii] = 99; 292$ioutarray->[$ii] = 99; 293$joutarray->[$ii] = 99; 294$eoutarray->[$ii] = 99.; 295$doutarray->[$ii] = 99.; 296 297for ($ii=0; $ii<$npixels;$ii++) { 298 ($boutarray->[$ii] != $binarray->[$ii]) and 299 print "bout != bin = $boutarray->[$ii] $binarray->[$ii]\n"; 300 ($ioutarray->[$ii] != $iinarray->[$ii]) and 301 print "iout != iin = $ioutarray->[$ii] $iinarray->[$ii]\n"; 302 ($joutarray->[$ii] != $jinarray->[$ii]) and 303 print "jout != jin = $joutarray->[$ii] $jinarray->[$ii]\n"; 304 ($eoutarray->[$ii] != $einarray->[$ii]) and 305 print "eout != ein = $eoutarray->[$ii] $einarray->[$ii]\n"; 306 ($doutarray->[$ii] != $dinarray->[$ii]) and 307 print "dout != din = $doutarray->[$ii] $dinarray->[$ii]\n"; 308} 309 310@{$binarray} = map(0,(0..$npixels-1)); 311@{$iinarray} = map(0,(0..$npixels-1)); 312@{$jinarray} = map(0,(0..$npixels-1)); 313@{$einarray} = map(0.0,(0..$npixels-1)); 314@{$dinarray} = map(0.0,(0..$npixels-1)); 315 316$anynull = 0; 317$fptr->read_imgnull_byt(1,1,10,$binarray,$larray,$anynull,$status); 318$fptr->read_imgnull_byt(1,11,10,$tmp1,$tmp2,$anynull,$status); 319@{$binarray}[10..$npixels-1] = @{$tmp1}; 320@{$larray}[10..$npixels-1] = @{$tmp2}; 321for ($ii=0;$ii<$npixels;$ii++) { 322 if ($larray->[$ii]) { print " *" } 323 else { printf " %2d",$binarray->[$ii] } 324} 325print " $anynull (ffgpfb)\n"; 326 327$fptr->read_imgnull_sht(1,1,$npixels,$iinarray,$larray,$anynull,$status); 328for ($ii=0;$ii<$npixels;$ii++) { 329 if ($larray->[$ii]) { print " *" } 330 else { printf " %2d",$iinarray->[$ii] } 331} 332print " $anynull (ffgpfi)\n"; 333 334$fptr->read_imgnull_lng(1,1,$npixels,$jinarray,$larray,$anynull,$status); 335for ($ii=0;$ii<$npixels;$ii++) { 336 if ($larray->[$ii]) { print " *" } 337 else { printf " %2d",$jinarray->[$ii] } 338} 339print " $anynull (ffgpfj)\n"; 340 341$fptr->read_imgnull_flt(1,1,$npixels,$einarray,$larray,$anynull,$status); 342for ($ii=0;$ii<$npixels;$ii++) { 343 if ($larray->[$ii]) { print " *" } 344 else { printf " %2.0f",$einarray->[$ii] } 345} 346print " $anynull (ffgpfe)\n"; 347 348$fptr->read_imgnull_dbl(1,1,10,$dinarray,$larray,$anynull,$status); 349$fptr->read_imgnull_dbl(1,11,10,$tmp1,$tmp2,$anynull,$status); 350@{$dinarray}[10..$npixels-1] = @{$tmp1}; 351@{$larray}[10..$npixels-1] = @{$tmp2}; 352for ($ii=0;$ii<$npixels;$ii++) { 353 if ($larray->[$ii]) { print " *" } 354 else { printf " %2.0f",$dinarray->[$ii] } 355} 356print " $anynull (ffgpfd)\n"; 357 358$status and print("ERROR: ffgpf_ status = $status\n"), goto ERRSTATUS; 359$anynull or print "ERROR: ffgpf_ did not detect null values\n"; 360 361 362########################################## 363# close and reopen file multiple times # 364########################################## 365 366for ($ii=0;$ii<10;$ii++) { 367 $fptr->close_file($status) and 368 print("ERROR in ftclos (1) = $status"), goto ERRSTATUS; 369 $fptr=Astro::FITS::CFITSIO::open_file($filename,READWRITE,$status); 370 $status and 371 print("ERROR: ffopen open file status = $status\n"), goto ERRSTATUS; 372} 373print "\nClosed then reopened the FITS file 10 times.\n"; 374print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 375 376$filename = ""; 377$fptr->file_name($filename,$status); 378$fptr->file_mode($filemode,$status); 379print "Name of file = $filename, I/O mode = $filemode\n"; 380 381 382############################ 383# read single keywords # 384############################ 385 386$simple = 0; 387$bitpix = 0; 388$naxis = 0; 389$naxes = [0,0]; 390$pcount = -99; 391$gcount = -99; 392$extend = -99; 393print "\nRead back keywords:\n"; 394$fptr->read_imghdr($simple,$bitpix,$naxis,$naxes,$pcount,$gcount,$extend,$status); 395print "simple = $simple, bitpix = $bitpix, naxis = $naxis, naxes = ($naxes->[0], $naxes->[1])\n"; 396print " pcount = $pcount, gcount = $gcount, extend = $extend\n"; 397 398$fptr->read_record(9,$card,$status); 399print $card,"\n"; 400(substr($card,0,15) eq "KEY_PREC= 'This") or print "ERROR in ffgrec\n"; 401 402$fptr->read_keyn(9,$keyword,$value,$comment,$status); 403print "$keyword : $value : $comment :\n"; 404($keyword eq 'KEY_PREC') or print "ERROR in ffgkyn: $keyword\n"; 405 406$fptr->read_card($keyword,$card,$status); 407print $card,"\n"; 408($keyword eq substr($card,0,8)) or print "ERROR in ffgcrd: $keyword\n"; 409 410$fptr->read_keyword('KY_PKNS1',$value,$comment,$status); 411print "KY_PKNS1 : $value : $comment :\n"; 412(substr($value,0,14) eq "'first string'") or print "ERROR in ffgkey $value\n"; 413 414$fptr->read_key_str('key_pkys',$iskey,$comment,$status); 415print "KEY_PKYS $iskey $comment $status\n"; 416 417$fptr->read_key_log('key_pkyl',$ilkey,$comment,$status); 418print "KEY_PKYL $ilkey $comment $status\n"; 419 420$fptr->read_key_lng('KEY_PKYJ',$ijkey,$comment,$status); 421print "KEY_PKYJ $ijkey $comment $status\n"; 422 423$fptr->read_key_flt('KEY_PKYJ',$iekey,$comment,$status); 424printf "KEY_PKYJ %f $comment $status\n",$iekey; 425 426$fptr->read_key_dbl('KEY_PKYJ',$idkey,$comment,$status); 427printf "KEY_PKYJ %f $comment $status\n",$idkey; 428 429($ijkey == 11 and $iekey == 11.0 and $idkey == 11.0) or 430 printf "ERROR in ffgky[jed]: %d, %f, %f\n",$ijkey,$iekey,$idkey; 431 432$iskey = ""; 433$fptr->read_key(TSTRING,'key_pkys',$iskey,$comment,$status); 434print "KEY_PKY S $iskey $comment $status\n"; 435 436$ilkey = 0; 437$fptr->read_key(TLOGICAL,'key_pkyl',$ilkey,$comment,$status); 438print "KEY_PKY L $ilkey $comment $status\n"; 439 440$fptr->read_key(TBYTE,'KEY_PKYJ',$cval,$comment,$status); 441print "KEY_PKY BYTE $cval $comment $status\n"; 442 443$fptr->read_key(TSHORT,'KEY_PKYJ',$ishtkey,$comment,$status); 444print "KEY_PKY SHORT $ishtkey $comment $status\n"; 445 446$fptr->read_key(TINT,'KEY_PKYJ',$ilkey,$comment,$status); 447print "KEY_PKY INT $ilkey $comment $status\n"; 448 449$ijkey=0; 450$fptr->read_key(TLONG,'KEY_PKYJ',$ijkey,$comment,$status); 451print "KEY_PKY J $ijkey $comment $status\n"; 452 453$iekey=0; 454$fptr->read_key(TFLOAT,'KEY_PKYE',$iekey,$comment,$status); 455printf "KEY_PKY E %f $comment $status\n",$iekey; 456 457$idkey=0; 458$fptr->read_key(TDOUBLE,'KEY_PKYD',$idkey,$comment,$status); 459printf "KEY_PKY D %f $comment $status\n",$idkey; 460 461$fptr->read_key_dbl('KEY_PKYF',$idkey,$comment,$status); 462printf "KEY_PKYF %f $comment $status\n",$idkey; 463 464$fptr->read_key_dbl('KEY_PKYE',$idkey,$comment,$status); 465printf "KEY_PKYE %f $comment $status\n",$idkey; 466 467$fptr->read_key_dbl('KEY_PKYG',$idkey,$comment,$status); 468printf "KEY_PKYG %.14f $comment $status\n",$idkey; 469 470$fptr->read_key_dbl('KEY_PKYD',$idkey,$comment,$status); 471printf "KEY_PKYD %.14f $comment $status\n",$idkey; 472 473$fptr->read_key_cmp('KEY_PKYC',$inekey,$comment,$status); 474printf "KEY_PKYC %f %f $comment $status\n",@$inekey; 475 476$fptr->read_key_cmp('KEY_PKFC',$inekey,$comment,$status); 477printf "KEY_PKFC %f %f $comment $status\n",@$inekey; 478 479$fptr->read_key_dblcmp('KEY_PKYM',$indkey,$comment,$status); 480printf "KEY_PKYM %f %f $comment $status\n",@$indkey; 481 482$fptr->read_key_dblcmp('KEY_PKFM',$indkey,$comment,$status); 483printf "KEY_PKFM %f %f $comment $status\n",@$indkey; 484 485$fptr->read_key_triple('KEY_PKYT',$ijkey,$idkey,$comment,$status); 486printf "KEY_PKYT $ijkey %.14f $comment $status\n",$idkey; 487 488$fptr->write_key_unit('KEY_PKYJ',"km/s/Mpc",$status); 489$ijkey=0; 490$fptr->read_key(TLONG,'KEY_PKYJ',$ijkey,$comment,$status); 491print "KEY_PKY J $ijkey $comment $status\n"; 492$fptr->read_key_unit('KEY_PKYJ',$comment,$status); 493print "KEY_PKY units = $comment\n"; 494 495$fptr->write_key_unit('KEY_PKYJ','',$status); 496$ijkey=0; 497$fptr->read_key(TLONG,'KEY_PKYJ',$ijkey,$comment,$status); 498print "KEY_PKY J $ijkey $comment $status\n"; 499$fptr->read_key_unit('KEY_PKYJ',$comment,$status); 500print "KEY_PKY units = $comment\n"; 501 502$fptr->write_key_unit('KEY_PKYJ','feet/second/second',$status); 503$ijkey=0; 504$fptr->read_key(TLONG,'KEY_PKYJ',$ijkey,$comment,$status); 505print "KEY_PKY J $ijkey $comment $status\n"; 506$fptr->read_key_unit('KEY_PKYJ',$comment,$status); 507print "KEY_PKY units = $comment\n"; 508 509$fptr->read_key_longstr('key_pkls',$lsptr,$comment,$status); 510print "KEY_PKLS long string value = \n$lsptr\n"; 511 512$fptr->get_hdrpos($existkeys,$keynum,$status); 513print "header contains $existkeys keywords; located at keyword $keynum \n"; 514 515############################ 516# read array keywords # 517############################ 518 519$fptr->read_keys_str('ky_pkns',1,3,$inskey,$nfound,$status); 520print "ffgkns: $inskey->[0], $inskey->[1], $inskey->[2]\n"; 521($nfound == 3 and $status == 0) or print "\nERROR in ffgkns $nfound, $status\n"; 522 523$fptr->read_keys_log('ky_pknl',1,3,$inlkey,$nfound,$status); 524print "ffgknl: $inlkey->[0], $inlkey->[1], $inlkey->[2]\n"; 525($nfound == 3 and $status == 0) or print "\nERROR in ffgknl $nfound, $status\n"; 526 527$fptr->read_keys_lng('ky_pknj',1,3,$injkey,$nfound,$status); 528print "ffgknj: $injkey->[0], $injkey->[1], $injkey->[2]\n"; 529($nfound == 3 and $status == 0) or print "\nERROR in ffgknj $nfound, $status\n"; 530 531$fptr->read_keys_flt('ky_pkne',1,3,$inekey,$nfound,$status); 532printf "ffgkne: %f, %f, %f\n",@{$inekey}; 533($nfound == 3 and $status == 0) or print "\nERROR in ffgkne $nfound, $status\n"; 534 535$fptr->read_keys_dbl('ky_pknd',1,3,$indkey,$nfound,$status); 536printf "ffgknd: %f, %f, %f\n",@{$indkey}; 537($nfound == 3 and $status == 0) or print "\nERROR in ffgknd $nfound, $status\n"; 538 539$fptr->read_card('HISTORY',$card,$status); 540$fptr->get_hdrpos($existkeys,$keynum,$status); 541$keynum -= 2; 542 543print "\nBefore deleting the HISTORY and DATE keywords...\n"; 544for ($ii=$keynum; $ii<=$keynum+3;$ii++) { 545 $fptr->read_record($ii,$card,$status); 546 print substr($card,0,8),"\n"; 547} 548 549############################ 550# delete keywords # 551############################ 552 553$fptr->delete_record($keynum+1,$status); 554$fptr->delete_key('DATE',$status); 555 556print "\nAfter deleting the keywords...\n"; 557for ($ii=$keynum; $ii<=$keynum+1;$ii++) { 558 $fptr->read_record($ii,$card,$status); 559 print $card,"\n"; 560} 561 562$status and print "ERROR deleting keywords\n"; 563 564############################ 565# insert keywords # 566############################ 567 568$keynum += 4; 569$fptr->insert_record($keynum-3,"KY_IREC = 'This keyword inserted by fxirec'",$status); 570$fptr->insert_key_str('KY_IKYS',"insert_value_string", "ikys comment", $status); 571$fptr->insert_key_lng('KY_IKYJ',49,"ikyj comment", $status); 572$fptr->insert_key_log('KY_IKYL',1, "ikyl comment", $status); 573$fptr->insert_key_flt('KY_IKYE',12.3456, 4, "ikye comment", $status); 574$fptr->insert_key_dbl('KY_IKYD',12.345678901234567, 14, "ikyd comment", $status); 575$fptr->insert_key_fixflt('KY_IKYF',12.3456, 4, "ikyf comment", $status); 576$fptr->insert_key_fixdbl('KY_IKYG',12.345678901234567, 13, "ikyg comment", $status); 577 578print "\nAfter inserting the keywords...\n"; 579for ($ii=$keynum-4; $ii<=$keynum+5;$ii++) { 580 $fptr->read_record($ii,$card,$status); 581 print $card,"\n"; 582} 583 584$status and print "ERROR inserting keywords\n"; 585 586############################ 587# modify keywords # 588############################ 589 590$fptr->modify_record($keynum-4,'COMMENT This keyword was modified by fxmrec', $status); 591$fptr->modify_card('KY_IREC',"KY_MREC = 'This keyword was modified by fxmcrd'",$status); 592$fptr->modify_name('KY_IKYS','NEWIKYS',$status); 593$fptr->modify_comment('KY_IKYJ','This is a modified comment', $status); 594$fptr->modify_key_lng('KY_IKYJ',50,'&',$status); 595$fptr->modify_key_log('KY_IKYL',0,'&',$status); 596$fptr->modify_key_str('NEWIKYS','modified_string', '&', $status); 597$fptr->modify_key_flt('KY_IKYE',-12.3456, 4, '&', $status); 598$fptr->modify_key_dbl('KY_IKYD',-12.345678901234567, 14, 'modified comment', $status); 599$fptr->modify_key_fixflt('KY_IKYF',-12.3456, 4, '&', $status); 600$fptr->modify_key_fixdbl('KY_IKYG',-12.345678901234567, 13, '&', $status); 601 602print "\nAfter modifying the keywords...\n"; 603for ($ii=$keynum-4; $ii<=$keynum+5;$ii++) { 604 $fptr->read_record($ii,$card,$status); 605 print $card,"\n"; 606} 607 608$status and print "ERROR modifying keywords\n"; 609 610############################ 611# update keywords # 612############################ 613 614$fptr->update_card('KY_MREC',"KY_UCRD = 'This keyword was updated by fxucrd'",$status); 615 616$fptr->update_key_lng('KY_IKYJ',51,'&',$status); 617$fptr->update_key_log('KY_IKYL',1,'&',$status); 618$fptr->update_key_str('NEWIKYS',"updated_string",'&',$status); 619$fptr->update_key_flt('KY_IKYE',-13.3456, 4,'&',$status); 620$fptr->update_key_dbl('KY_IKYD',-13.345678901234567, 14,'modified comment',$status); 621$fptr->update_key_fixflt('KY_IKYF',-13.3456, 4,'&',$status); 622$fptr->update_key_fixdbl('KY_IKYG',-13.345678901234567, 13,'&',$status); 623 624print "\nAfter updating the keywords...\n"; 625for ($ii=$keynum-4; $ii<=$keynum+5;$ii++) { 626 $fptr->read_record($ii,$card,$status); 627 print $card,"\n"; 628} 629 630$status and print "ERROR modifying keywords\n"; 631 632$fptr->read_record(0,$card,$status); 633 634print "\nKeywords found using wildcard search (should be 13)...\n"; 635$nfound = 0; 636while (!$fptr->find_nextkey($inclist,2,$exclist,2,$card,$status)) { 637 $nfound++; 638 print $card,"\n"; 639} 640($nfound == 13) or print("\nERROR reading keywords using wildcards (ffgnxk)\n"), goto ERRSTATUS; 641 642$status=0; 643 644############################ 645# copy index keyword # 646############################ 647 648$fptr->copy_key($fptr,1,4,'KY_PKNE',$status); 649$fptr->read_keys_str('ky_pkne',2,4,$inekey,$nfound,$status); 650printf "\nCopied keyword: ffgkne: %f, %f, %f\n", @$inekey; 651 652$status and print("\nERROR in ffgkne $nfound, $status\n"),goto ERRSTATUS; 653 654###################################### 655# modify header using template file # 656###################################### 657 658$fptr->write_key_template($template,$status) and 659 print "\nERROR returned by ffpktp\n", goto ERRSTATUS; 660print "Updated header using template file (ffpktp)\n"; 661 662############################ 663# create binary table # 664############################ 665 666$tform = [ qw( 15A 1L 16X 1B 1I 1J 1E 1D 1C 1M ) ]; 667$ttype = [ qw( Avalue Lvalue Xvalue Bvalue Ivalue Jvalue Evalue Dvalue Cvalue Mvalue ) ]; 668$tunit = [ ( '', 'm**2', 'cm', 'erg/s', 'km/s', '', '', '', '', '') ]; 669 670$nrows = 21; 671$tfields = 10; 672$pcount = 0; 673 674$fptr->insert_btbl($nrows,$tfields,$ttype,$tform,$tunit,$binname,0,$status); 675print "\nffibin status = $status\n"; 676print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 677 678$fptr->get_hdrpos($existkeys,$keynum,$status); 679print "header contains $existkeys keywords; located at keyword $keynum \n"; 680 681$morekeys=40; 682$fptr->set_hdrsize($morekeys,$status); 683$fptr->get_hdrspace($existkeys,$morekeys,$status); 684print "header contains $existkeys keywords with room for $morekeys more\n"; 685 686$fptr->set_btblnull(4,99,$status); 687$fptr->set_btblnull(5,99,$status); 688$fptr->set_btblnull(6,99,$status); 689 690$extvers=1; 691$fptr->write_key_lng('EXTVER',$extvers,'extension version number', $status); 692$fptr->write_key_lng('TNULL4',99,'value for undefined pixels',$status); 693$fptr->write_key_lng('TNULL5',99,'value for undefined pixels',$status); 694$fptr->write_key_lng('TNULL6',99,'value for undefined pixels',$status); 695 696$naxis=3; 697$naxes=[1,2,8]; 698$fptr->write_tdim(3,$naxis,$naxes,$status); 699$naxis=0; 700$naxes=undef; 701$fptr->read_tdim(3,$naxis,$naxes,$status); 702$fptr->read_key_str('TDIM3',$iskey,$comment,$status); 703print "TDIM3 = $iskey, $naxis, $naxes->[0], $naxes->[1], $naxes->[2]\n"; 704 705$fptr->set_hdustruc($status); 706 707############################ 708# write data to columns # 709############################ 710 711$signval = -1; 712for ($ii=0;$ii<21;$ii++) { 713 $signval *= -1; 714 $boutarray->[$ii] = ($ii + 1); 715 $ioutarray->[$ii] = ($ii + 1) * $signval; 716 $joutarray->[$ii] = ($ii + 1) * $signval; 717 $koutarray->[$ii] = ($ii + 1) * $signval; 718 $eoutarray->[$ii] = ($ii + 1) * $signval; 719 $doutarray->[$ii] = ($ii + 1) * $signval; 720} 721 722$fptr->write_col_str(1,1,1,3,$onskey,$status); 723$fptr->write_col_null(1,4,1,1,$status); 724 725$larray = [0,1,0,0,1,1,0,0,0,1,1,1,0,0,0,0,1,1,1,1,0,0,0,0,0,1,1,1,1,1,0,0,0,0,0,0]; 726$fptr->write_col_bit(3,1,1,36,$larray,$status); 727 728for ($ii=4;$ii<9;$ii++) { 729 $fptr->write_col_byt($ii,1,1,2,$boutarray,$status); 730 ($status == NUM_OVERFLOW) and $status = 0; 731 $fptr->write_col_sht($ii,3,1,2,[@{$ioutarray}[2..3]],$status); 732 ($status == NUM_OVERFLOW) and $status = 0; 733 $fptr->write_col_int($ii,5,1,2,[@{$koutarray}[4..5]],$status); 734 ($status == NUM_OVERFLOW) and $status = 0; 735 $fptr->write_col_flt($ii,7,1,2,[@{$eoutarray}[6..7]],$status); 736 ($status == NUM_OVERFLOW) and $status = 0; 737 $fptr->write_col_dbl($ii,9,1,2,[@{$doutarray}[8..9]],$status); 738 ($status == NUM_OVERFLOW) and $status = 0; 739 $fptr->write_col_null($ii,11,1,1,$status); 740} 741 742$fptr->write_col_cmp(9,1,1,10,$eoutarray,$status); 743$fptr->write_col_dblcmp(10,1,1,10,$doutarray,$status); 744 745for ($ii=4;$ii<9;$ii++) { 746 $fptr->write_colnull_byt($ii,12,1,2,[@{$boutarray}[11..12]],13,$status); 747 ($status == NUM_OVERFLOW) and $status = 0; 748 $fptr->write_colnull_sht($ii,14,1,2,[@{$ioutarray}[13..14]],15,$status); 749 ($status == NUM_OVERFLOW) and $status = 0; 750 $fptr->write_colnull_int($ii,16,1,2,[@{$koutarray}[15..16]],17,$status); 751 ($status == NUM_OVERFLOW) and $status = 0; 752 $fptr->write_colnull_flt($ii,18,1,2,[@{$eoutarray}[17..18]],19.,$status); 753 ($status == NUM_OVERFLOW) and $status = 0; 754 $fptr->write_colnull_dbl($ii,20,1,2,[@{$doutarray}[19..20]],21.,$status); 755 ($status == NUM_OVERFLOW) and $status = 0; 756} 757$fptr->write_col_log(2,1,1,21,$larray,$status); 758$fptr->write_col_null(2,11,1,1,$status); 759print "ffpcl_ status = $status\n"; 760 761######################################### 762# get information about the columns # 763######################################### 764 765print "\nFind the column numbers; a returned status value of 237 is"; 766print "\nexpected and indicates that more than one column name matches"; 767print "\nthe input column name template. Status = 219 indicates that"; 768print "\nthere was no matching column name."; 769 770$fptr->get_colnum(0,'Xvalue',$colnum,$status); 771print "\nColumn Xvalue is number $colnum; status = $status.\n"; 772 773while ($status != COL_NOT_FOUND) { 774 $fptr->get_colname(1,'*ue',$colname,$colnum,$status); 775 print "Column $colname is number $colnum; status = $status.\n"; 776} 777$status = 0; 778 779print "\nInformation about each column:\n"; 780for ($ii=0;$ii<$tfields;$ii++) { 781 $fptr->get_coltype($ii+1,$typecode,$repeat,$width,$status); 782 printf("%4s %3d %2d %2d", $tform->[$ii], $typecode, $repeat, $width); 783 $fptr->get_bcolparms($ii+1,$ttype->[0],$tunit->[0],$cval,$repeat,$scale,$zero,$jnulval,$tdisp,$status); 784 printf " $ttype->[0], $tunit->[0], $cval, $repeat, %f, %f, $jnulval, $tdisp.\n",$scale,$zero; 785} 786print "\n"; 787 788############################################### 789# insert ASCII table before the binary table # 790############################################### 791 792$fptr->movrel_hdu(-1,$hdutype,$status) and goto ERRSTATUS; 793 794$tform = [ qw( A15 I10 F14.6 E12.5 D21.14 ) ]; 795$ttype = [ qw( Name Ivalue Fvalue Evalue Dvalue ) ]; 796$tunit = [ ('','m**2','cm','erg/s','km/s') ]; 797$rowlen = 76; 798$nrows = 11; 799$tfields = 5; 800 801$fptr->insert_atbl($rowlen,$nrows,$tfields,$ttype,$tbcol,$tform,$tunit,$tblname,$status); 802print "ffitab status = $status\n"; 803print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 804 805$fptr->set_atblnull(1,'null1',$status); 806$fptr->set_atblnull(2,'null2',$status); 807$fptr->set_atblnull(3,'null3',$status); 808$fptr->set_atblnull(4,'null4',$status); 809$fptr->set_atblnull(5,'null5',$status); 810 811$extvers=2; 812$fptr->write_key_lng('EXTVER',$extvers,'extension version number',$status); 813$fptr->write_key_str('TNULL1','null1','value for undefined pixels',$status); 814$fptr->write_key_str('TNULL2','null2','value for undefined pixels',$status); 815$fptr->write_key_str('TNULL3','null3','value for undefined pixels',$status); 816$fptr->write_key_str('TNULL4','null4','value for undefined pixels',$status); 817$fptr->write_key_str('TNULL5','null5','value for undefined pixels',$status); 818 819$status and goto ERRSTATUS; 820 821############################ 822# write data to columns # 823############################ 824 825for ($ii=0;$ii<21;$ii++) { 826 $boutarray->[$ii] = $ii+1; 827 $ioutarray->[$ii] = $ii+1; 828 $joutarray->[$ii] = $ii+1; 829 $eoutarray->[$ii] = $ii+1; 830 $doutarray->[$ii] = $ii+1; 831} 832 833$fptr->write_col_str(1,1,1,3,$onskey,$status); 834$fptr->write_col_null(1,4,1,1,$status); 835 836for ($ii=2;$ii<6;$ii++) { 837 $fptr->write_col_byt($ii,1,1,2,[@{$boutarray}[0..1]],$status); 838 ($status == NUM_OVERFLOW) and $status = 0; 839 $fptr->write_col_sht($ii,3,1,2,[@{$ioutarray}[2..3]],$status); 840 ($status == NUM_OVERFLOW) and $status = 0; 841 $fptr->write_col_lng($ii,5,1,2,[@{$joutarray}[4..5]],$status); 842 ($status == NUM_OVERFLOW) and $status = 0; 843 $fptr->write_col_flt($ii,7,1,2,[@{$eoutarray}[6..7]],$status); 844 ($status == NUM_OVERFLOW) and $status = 0; 845 $fptr->write_col_dbl($ii,9,1,2,[@{$doutarray}[8..9]],$status); 846 ($status == NUM_OVERFLOW) and $status = 0; 847 848 $fptr->write_col_null($ii,11,1,1,$status); 849} 850print "ffpcl_ status = $status\n"; 851 852################################ 853# read data from ASCII table # 854################################ 855 856$fptr->read_atblhdr($rowlen,$nrows,$tfields,$ttype,$tbcol,$tform,$tunit,$tblname,$status); 857 858print "\nASCII table: rowlen, nrows, tfields, extname: $rowlen $nrows $tfields $tblname\n"; 859for ($ii=0;$ii<$tfields;$ii++) { 860 printf "%8s %3d %8s %8s \n", $ttype->[$ii], $tbcol->[$ii], $tform->[$ii], $tunit->[$ii]; 861} 862 863$nrows = 11; 864 865$fptr->read_col_str(1,1,1,$nrows,'UNDEFINED',$inskey,$anynull,$status); 866$fptr->read_col_byt(2,1,1,$nrows,99,$binarray,$anynull,$status); 867$fptr->read_col_sht(2,1,1,$nrows,99,$iinarray,$anynull,$status); 868$fptr->read_col_lng(3,1,1,$nrows,99,$jinarray,$anynull,$status); 869$fptr->read_col_flt(4,1,1,$nrows,99,$einarray,$anynull,$status); 870$fptr->read_col_dbl(5,1,1,$nrows,99,$dinarray,$anynull,$status); 871 872print "\nData values read from ASCII table:\n"; 873for ($ii=0;$ii<$nrows;$ii++) { 874 printf("%15s %2d %2d %2d %4.1f %4.1f\n", 875 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], $jinarray->[$ii], 876 $einarray->[$ii], $dinarray->[$ii] 877 ); 878} 879 880$fptr->read_tblbytes(1,20,78,$uchars,$status); 881print "\n",pack("C78",@$uchars),"\n"; 882$fptr->write_tblbytes(1,20,78,$uchars,$status); 883 884######################################### 885# get information about the columns # 886######################################### 887 888$fptr->get_colnum(0,'name',$colnum,$status); 889print "\nColumn name is number $colnum; status = $status.\n"; 890 891while ($status != COL_NOT_FOUND) { 892 $fptr->get_colname(0,'*ue',$colname,$colnum,$status); 893 print "Column $colname is number $colnum; status = $status.\n"; 894} 895$status = 0; 896 897for ($ii=0;$ii<$tfields;$ii++) { 898 $fptr->get_coltype($ii+1,$typecode,$repeat,$width,$status); 899 printf "%4s %3d %2d %2d", $tform->[$ii], $typecode, $repeat, $width; 900 $fptr->get_acolparms($ii+1,$ttype->[0],$tbcol,$tunit->[0],$tform->[0],$scale, 901 $zero,$nulstr,$tdisp,$status); 902 printf " $ttype->[0], $tbcol, $tunit->[0], $tform->[0], %f, %f, $nulstr, $tdisp.\n", 903 $scale, $zero; 904} 905print "\n"; 906 907############################################### 908# test the insert/delete row/column routines # 909############################################### 910 911$fptr->insert_rows(2,3,$status) and goto ERRSTATUS; 912 913$nrows = 14; 914 915$fptr->read_col_str(1,1,1,$nrows,'UNDEFINED',$inskey,$anynull,$status); 916$fptr->read_col_byt(2,1,1,$nrows,99,$binarray,$anynull,$status); 917$fptr->read_col_sht(2,1,1,$nrows,99,$iinarray,$anynull,$status); 918$fptr->read_col_lng(3,1,1,$nrows,99,$jinarray,$anynull,$status); 919$fptr->read_col_flt(4,1,1,$nrows,99,$einarray,$anynull,$status); 920$fptr->read_col_dbl(5,1,1,$nrows,99,$dinarray,$anynull,$status); 921 922print "\nData values after inserting 3 rows after row 2:\n"; 923for ($ii=0;$ii<$nrows;$ii++) { 924 printf("%15s %2d %2d %2d %4.1f %4.1f\n", 925 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], 926 $jinarray->[$ii], $einarray->[$ii], $dinarray->[$ii] 927 ); 928} 929 930$fptr->delete_rows(10,2,$status) and goto ERRSTATUS; 931 932$nrows = 12; 933 934$fptr->read_col_str(1,1,1,$nrows,'UNDEFINED',$inskey,$anynull,$status); 935$fptr->read_col_byt(2,1,1,$nrows,99,$binarray,$anynull,$status); 936$fptr->read_col_sht(2,1,1,$nrows,99,$iinarray,$anynull,$status); 937$fptr->read_col_lng(3,1,1,$nrows,99,$jinarray,$anynull,$status); 938$fptr->read_col_flt(4,1,1,$nrows,99,$einarray,$anynull,$status); 939$fptr->read_col_dbl(5,1,1,$nrows,99,$dinarray,$anynull,$status); 940 941print "\nData values after deleting 2 rows at row 10:\n"; 942for ($ii=0;$ii<$nrows;$ii++) { 943 printf("%15s %2d %2d %2d %4.1f %4.1f\n", 944 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], 945 $jinarray->[$ii], $einarray->[$ii], $dinarray->[$ii] 946 ); 947} 948 949$fptr->delete_col(3,$status) and goto ERRSTATUS; 950 951$fptr->read_col_str(1,1,1,$nrows,'UNDEFINED',$inskey,$anynull,$status); 952$fptr->read_col_byt(2,1,1,$nrows,99,$binarray,$anynull,$status); 953$fptr->read_col_sht(2,1,1,$nrows,99,$iinarray,$anynull,$status); 954$fptr->read_col_flt(3,1,1,$nrows,99,$einarray,$anynull,$status); 955$fptr->read_col_dbl(4,1,1,$nrows,99,$dinarray,$anynull,$status); 956 957print "\nData values after deleting column 3:\n"; 958for ($ii=0;$ii<$nrows;$ii++) { 959 printf("%15s %2d %2d %4.1f %4.1f\n", 960 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], 961 $einarray->[$ii], $dinarray->[$ii] 962 ); 963} 964 965$fptr->insert_col(5,'INSERT_COL','F14.6',$status) and goto ERRSTATUS; 966 967$fptr->read_col_str(1,1,1,$nrows,'UNDEFINED',$inskey,$anynull,$status); 968$fptr->read_col_byt(2,1,1,$nrows,99,$binarray,$anynull,$status); 969$fptr->read_col_sht(2,1,1,$nrows,99,$iinarray,$anynull,$status); 970$fptr->read_col_flt(3,1,1,$nrows,99,$einarray,$anynull,$status); 971$fptr->read_col_dbl(4,1,1,$nrows,99,$dinarray,$anynull,$status); 972$fptr->read_col_lng(5,1,1,$nrows,99,$jinarray,$anynull,$status); 973 974print "\nData values after inserting column 5:\n"; 975for ($ii=0;$ii<$nrows;$ii++) { 976 printf("%15s %2d %2d %4.1f %4.1f %d\n", 977 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], 978 $einarray->[$ii], $dinarray->[$ii], $jinarray->[$ii], 979 ); 980} 981 982############################################################ 983# create a temporary file and copy the ASCII table to it, # 984# column by column. # 985############################################################ 986 987$bitpix=16; 988$naxis=0; 989$filename = '!t1q2s3v6.tmp'; 990$tmpfptr=Astro::FITS::CFITSIO::create_file($filename,$status); 991print "Create temporary file: ffinit status = $status\n"; 992 993$tmpfptr->insert_img($bitpix,$naxis,$naxes,$status); 994print "\nCreate null primary array: ffiimg status = $status\n"; 995 996$nrows=12; 997$tfields=0; 998$rowlen=0; 999 1000$tmpfptr->insert_atbl($rowlen,$nrows,$tfields,$ttype,$tbcol,$tform,$tunit,$tblname,$status); 1001print "\nCreate ASCII table with 0 columns: ffitab status = $status\n"; 1002 1003$fptr->copy_col($tmpfptr,4,1,TRUE,$status); 1004print "copy column, ffcpcl status = $status\n"; 1005$fptr->copy_col($tmpfptr,3,1,TRUE,$status); 1006print "copy column, ffcpcl status = $status\n"; 1007$fptr->copy_col($tmpfptr,2,1,TRUE,$status); 1008print "copy column, ffcpcl status = $status\n"; 1009$fptr->copy_col($tmpfptr,1,1,TRUE,$status); 1010print "copy column, ffcpcl status = $status\n"; 1011 1012$tmpfptr->insert_btbl($nrows,$tfields,$ttype,$tform,$tunit,$tblname,0,$status); 1013print "\nCreate Binary table with 0 columns: ffibin status = $status\n"; 1014 1015$fptr->copy_col($tmpfptr,4,1,TRUE,$status); 1016print "copy column, ffcpcl status = $status\n"; 1017$fptr->copy_col($tmpfptr,3,1,TRUE,$status); 1018print "copy column, ffcpcl status = $status\n"; 1019$fptr->copy_col($tmpfptr,2,1,TRUE,$status); 1020print "copy column, ffcpcl status = $status\n"; 1021$fptr->copy_col($tmpfptr,1,1,TRUE,$status); 1022print "copy column, ffcpcl status = $status\n"; 1023 1024$tmpfptr->delete_file($status); 1025print "Delete the tmp file: ffdelt status = $status\n"; 1026 1027$status and goto ERRSTATUS; 1028 1029################################ 1030# read data from binary table # 1031################################ 1032 1033$fptr->movrel_hdu(1,$hdutype,$status) and goto ERRSTATUS; 1034print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 1035 1036$fptr->get_hdrspace($existkeys,$morekeys,$status); 1037print "header contains $existkeys keywords with room for $morekeys more\n"; 1038 1039$fptr->read_btblhdr($nrows,$tfields,$ttype,$tform,$tunit,$binname,$pcount,$status); 1040print "\nBinary table: nrows, tfields, extname, pcount: $nrows $tfields $binname $pcount\n"; 1041 1042for ($ii=0;$ii<$tfields;$ii++) { 1043 printf "%8s %8s %8s \n", $ttype->[$ii], $tform->[$ii], $tunit->[$ii]; 1044} 1045 1046@$larray = map(0,(0..39)); 1047print "\nData values read from binary table:\n"; 1048printf " Bit column (X) data values: \n\n"; 1049 1050$fptr->read_col_bit(3,1,1,36,$larray,$status); 1051for ($jj=0;$jj<5;$jj++) { 1052 print @{$larray}[$jj*8..$jj*8+7]; 1053 print " "; 1054} 1055 1056@{$larray} = map(0,(0..$nrows-1)); 1057@{$xinarray} = map(0,(0..$nrows-1)); 1058@{$binarray} = map(0,(0..$nrows-1)); 1059@{$iinarray} = map(0,(0..$nrows-1)); 1060@{$kinarray} = map(0,(0..$nrows-1)); 1061@{$einarray} = map(0.0,(0..$nrows-1)); 1062@{$dinarray} = map(0.0,(0..$nrows-1)); 1063@{$cinarray} = map(0.0,(0..2*$nrows-1)); 1064@{$minarray} = map(0.0,(0..2*$nrows-1)); 1065 1066print "\n\n"; 1067 1068$fptr->read_col_str(1,4,1,1,'',$inskey,$anynull,$status); 1069print "null string column value = -$inskey->[0]- (should be --)\n"; 1070 1071$nrows=21; 1072$fptr->read_col_str(1,1,1,$nrows,'NOT DEFINED',$inskey,$anynull,$status); 1073$fptr->read_col_log(2,1,1,$nrows,0,$larray,$anynull,$status); 1074$fptr->read_col_byt(3,1,1,$nrows,98,$xinarray,$anynull,$status); 1075$fptr->read_col_byt(4,1,1,$nrows,98,$binarray,$anynull,$status); 1076$fptr->read_col_sht(5,1,1,$nrows,98,$iinarray,$anynull,$status); 1077$fptr->read_col_lng(6,1,1,$nrows,98,$kinarray,$anynull,$status); 1078$fptr->read_col_flt(7,1,1,$nrows,98.,$einarray,$anynull,$status); 1079$fptr->read_col_dbl(8,1,1,$nrows,98.,$dinarray,$anynull,$status); 1080$fptr->read_col_cmp(9,1,1,$nrows,98.,$cinarray,$anynull,$status); 1081$fptr->read_col_dblcmp(10,1,1,$nrows,98.,$minarray,$anynull,$status); 1082 1083print "\nRead columns with ffgcv_:\n"; 1084for ($ii=0;$ii<$nrows;$ii++) { 1085 printf "%15s %d %3d %2d %3d %3d %5.1f %5.1f (%5.1f,%5.1f) (%5.1f,%5.1f) \n", 1086 $inskey->[$ii], $larray->[$ii], $xinarray->[$ii], $binarray->[$ii], 1087 $iinarray->[$ii],$kinarray->[$ii], $einarray->[$ii], $dinarray->[$ii], 1088 @{$cinarray->[$ii]}, @{$minarray->[$ii]}; 1089} 1090 1091@tmp = (0..$nrows-1); 1092@$larray = @tmp; 1093@$xinarray = @tmp; 1094@$binarray = @tmp; 1095@$iinarray = @tmp; 1096@$kinarray = @tmp; 1097@$einarray = @tmp; 1098@$dinarray = @tmp; 1099@tmp = (0..2*$nrows-1); 1100@$cinarray = @tmp; 1101@$minarray = @tmp; 1102 1103$fptr->read_colnull_str(1,1,1,$nrows,$inskey,$larray2,$anynull,$status); 1104$fptr->read_colnull_log(2,1,1,$nrows,$larray,$larray2,$anynull,$status); 1105$fptr->read_colnull_byt(3,1,1,$nrows,$xinarray,$larray2,$anynull,$status); 1106$fptr->read_colnull_byt(4,1,1,$nrows,$binarray,,$larray2,$anynull,$status); 1107$fptr->read_colnull_sht(5,1,1,$nrows,$iinarray,$larray2,$anynull,$status); 1108$fptr->read_colnull_int(6,1,1,$nrows,$kinarray,$larray2,$anynull,$status); 1109$fptr->read_colnull_flt(7,1,1,$nrows,$einarray,$larray2,$anynull,$status); 1110$fptr->read_colnull_dbl(8,1,1,$nrows,$dinarray,$larray2,$anynull,$status); 1111$fptr->read_colnull_cmp(9,1,1,$nrows,$cinarray,$larray2,$anynull,$status); 1112$fptr->read_colnull_dblcmp(10,1,1,$nrows,$minarray,$larray2,$anynull,$status); 1113 1114print "\nRead columns with ffgcf_:\n"; 1115for ($ii=0;$ii<10;$ii++) { 1116 printf "%15s %d %3d %2d %3d %3d %5.1f %5.1f (%5.1f,%5.1f) (%5.1f,%5.1f)\n", 1117 $inskey->[$ii], $larray->[$ii], $xinarray->[$ii], $binarray->[$ii], 1118 $iinarray->[$ii], $kinarray->[$ii], $einarray->[$ii], $dinarray->[$ii], 1119 @{$cinarray->[$ii]}, @{$minarray->[$ii]}; 1120} 1121 1122for ($ii=10; $ii<$nrows;$ii++) { 1123 printf "%15s %d %3d %2d %3d \n", 1124 $inskey->[$ii], $larray->[$ii], $xinarray->[$ii], $binarray->[$ii], 1125 $iinarray->[$ii]; 1126} 1127$fptr->write_record("key_prec= 'This keyword was written by f_prec' / comment here", $status); 1128 1129############################################### 1130# test the insert/delete row/column routines # 1131############################################### 1132 1133$fptr->insert_rows(2,3,$status) and goto ERRSTATUS; 1134$nrows=14; 1135$fptr->read_col_str(1,1,1,$nrows,'NOT DEFINED',$inskey,$anynull,$status); 1136$fptr->read_col_byt(4,1,1,$nrows,98,$binarray,$anynull,$status); 1137$fptr->read_col_sht(5,1,1,$nrows,98,$iinarray,$anynull,$status); 1138$fptr->read_col_lng(6,1,1,$nrows,98,$jinarray,$anynull,$status); 1139$fptr->read_col_flt(7,1,1,$nrows,98.,$einarray,$anynull,$status); 1140$fptr->read_col_dbl(8,1,1,$nrows,98.,$dinarray,$anynull,$status); 1141 1142print "\nData values after inserting 3 rows after row 2:\n"; 1143for ($ii = 0; $ii < $nrows; $ii++) { 1144 printf "%15s %2d %3d %3d %5.1f %5.1f\n", 1145 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], $jinarray->[$ii], 1146 $einarray->[$ii], $dinarray->[$ii]; 1147} 1148 1149$fptr->delete_rows(10,2,$status) and goto ERRSTATUS; 1150 1151$nrows=12; 1152$fptr->read_col_str(1,1,1,$nrows,'NOT DEFINED',$inskey,$anynull,$status); 1153$fptr->read_col_byt(4,1,1,$nrows,98,$binarray,$anynull,$status); 1154$fptr->read_col_sht(5,1,1,$nrows,98,$iinarray,$anynull,$status); 1155$fptr->read_col_lng(6,1,1,$nrows,98,$jinarray,$anynull,$status); 1156$fptr->read_col_flt(7,1,1,$nrows,98.,$einarray,$anynull,$status); 1157$fptr->read_col_dbl(8,1,1,$nrows,98.,$dinarray,$anynull,$status); 1158 1159print "\nData values after deleting 2 rows at row 10:\n"; 1160for ($ii = 0; $ii < $nrows; $ii++) { 1161 printf "%15s %2d %3d %3d %5.1f %5.1f\n", 1162 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], $jinarray->[$ii], 1163 $einarray->[$ii], $dinarray->[$ii]; 1164} 1165 1166$fptr->delete_col(6,$status) and goto ERRSTATUS; 1167$fptr->read_col_str(1,1,1,$nrows,'NOT DEFINED',$inskey,$anynull,$status); 1168$fptr->read_col_byt(4,1,1,$nrows,98,$binarray,$anynull,$status); 1169$fptr->read_col_sht(5,1,1,$nrows,98,$iinarray,$anynull,$status); 1170$fptr->read_col_flt(6,1,1,$nrows,98.,$einarray,$anynull,$status); 1171$fptr->read_col_dbl(7,1,1,$nrows,98.,$dinarray,$anynull,$status); 1172 1173print "\nData values after deleting column 6:\n"; 1174for ($ii = 0; $ii < $nrows; $ii++) { 1175 printf "%15s %2d %3d %5.1f %5.1f\n", 1176 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], $einarray->[$ii], 1177 $dinarray->[$ii]; 1178} 1179 1180$fptr->insert_col(8,'INSERT_COL','1E',$status) and goto ERRSTATUS; 1181$fptr->read_col_str(1,1,1,$nrows,'NOT DEFINED',$inskey,$anynull,$status); 1182$fptr->read_col_byt(4,1,1,$nrows,98,$binarray,$anynull,$status); 1183$fptr->read_col_sht(5,1,1,$nrows,98,$iinarray,$anynull,$status); 1184$fptr->read_col_flt(6,1,1,$nrows,98.,$einarray,$anynull,$status); 1185$fptr->read_col_dbl(7,1,1,$nrows,98.,$dinarray,$anynull,$status); 1186$fptr->read_col_lng(8,1,1,$nrows,98,$jinarray,$anynull,$status); 1187 1188print "\nData values after inserting column 8:\n"; 1189for ($ii = 0; $ii < $nrows; $ii++) { 1190 printf "%15s %2d %3d %5.1f %5.1f %d\n", 1191 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], $einarray->[$ii], 1192 $dinarray->[$ii] , $jinarray->[$ii]; 1193} 1194 1195 1196$fptr->write_col_null(8,1,1,10,$status); 1197$fptr->read_col_str(1,1,1,$nrows,'NOT DEFINED',$inskey,$anynull,$status); 1198$fptr->read_col_byt(4,1,1,$nrows,98,$binarray,$anynull,$status); 1199$fptr->read_col_sht(5,1,1,$nrows,98,$iinarray,$anynull,$status); 1200$fptr->read_col_flt(6,1,1,$nrows,98.,$einarray,$anynull,$status); 1201$fptr->read_col_dbl(7,1,1,$nrows,98.,$dinarray,$anynull,$status); 1202$fptr->read_col_lng(8,1,1,$nrows,98,$jinarray,$anynull,$status); 1203 1204print "\nValues after setting 1st 10 elements in column 8 = null:\n"; 1205for ($ii = 0; $ii < $nrows; $ii++) { 1206 printf "%15s %2d %3d %5.1f %5.1f %d\n", 1207 $inskey->[$ii], $binarray->[$ii], $iinarray->[$ii], $einarray->[$ii], 1208 $dinarray->[$ii] , $jinarray->[$ii]; 1209} 1210 1211############################################################ 1212# create a temporary file and copy the binary table to it,# 1213# column by column. # 1214############################################################ 1215 1216$bitpix=16; 1217$naxis=0; 1218$filename = '!t1q2s3v5.tmp'; 1219 1220$tmpfptr=Astro::FITS::CFITSIO::create_file($filename,$status); 1221print "Create temporary file: ffinit status = $status\n"; 1222 1223$tmpfptr->insert_img($bitpix,$naxis,$naxes,$status); 1224print "\nCreate null primary array: ffiimg status = $status\n"; 1225 1226$nrows=22; 1227$tfields=0; 1228$tmpfptr->insert_btbl($nrows,$tfields,$ttype,$tform,$tunit,$binname,0,$status); 1229print "\nCreate binary table with 0 columns: ffibin status = $status\n"; 1230 1231$fptr->copy_col($tmpfptr,7,1,TRUE,$status); 1232print "copy column, ffcpcl status = $status\n"; 1233$fptr->copy_col($tmpfptr,6,1,TRUE,$status); 1234print "copy column, ffcpcl status = $status\n"; 1235$fptr->copy_col($tmpfptr,5,1,TRUE,$status); 1236print "copy column, ffcpcl status = $status\n"; 1237$fptr->copy_col($tmpfptr,4,1,TRUE,$status); 1238print "copy column, ffcpcl status = $status\n"; 1239$fptr->copy_col($tmpfptr,3,1,TRUE,$status); 1240print "copy column, ffcpcl status = $status\n"; 1241$fptr->copy_col($tmpfptr,2,1,TRUE,$status); 1242print "copy column, ffcpcl status = $status\n"; 1243$fptr->copy_col($tmpfptr,1,1,TRUE,$status); 1244print "copy column, ffcpcl status = $status\n"; 1245 1246$tmpfptr->delete_file($status); 1247print "Delete the tmp file: ffdelt status = $status\n"; 1248 1249$status and goto ERRSTATUS; 1250 1251#################################################### 1252# insert binary table following the primary array # 1253#################################################### 1254 1255$fptr->movabs_hdu(1,$hdutype,$status); 1256$tform = [ qw( 15A 1L 16X 1B 1I 1J 1E 1D 1C 1M ) ]; 1257$ttype = [ qw( Avalue Lvalue Xvalue Bvalue Ivalue Jvalue Evalue Dvalue Cvalue Mvalue ) ]; 1258$tunit = [ ( '', 'm**2', 'cm', 'erg/s', 'km/s', '', '', '', '', '' ) ]; 1259 1260$nrows=20; 1261$tfields=10; 1262$pcount=0; 1263 1264$fptr->insert_btbl($nrows,$tfields,$ttype,$tform,$tunit,$binname,$pcount,$status); 1265print "ffibin status = $status\n"; 1266print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 1267 1268$extvers=3; 1269$fptr->write_key_lng('EXTVER',$extvers,'extension version number',$status); 1270 1271$fptr->write_key_lng('TNULL4',77,'value for undefined pixels',$status); 1272$fptr->write_key_lng('TNULL5',77,'value for undefined pixels',$status); 1273$fptr->write_key_lng('TNULL6',77,'value for undefined pixels',$status); 1274 1275$fptr->write_key_lng('TSCAL4',1000,'scaling factor',$status); 1276$fptr->write_key_lng('TSCAL5',1,'scaling factor',$status); 1277$fptr->write_key_lng('TSCAL6',100,'scaling factor',$status); 1278 1279$fptr->write_key_lng('TZERO4',0,'scaling offset',$status); 1280$fptr->write_key_lng('TZERO5',32768,'scaling offset',$status); 1281$fptr->write_key_lng('TZERO6',100,'scaling offset',$status); 1282 1283$fptr->set_btblnull(4,77,$status); 1284$fptr->set_btblnull(5,77,$status); 1285$fptr->set_btblnull(6,77,$status); 1286 1287$fptr->set_tscale(4,1000.,0.,$status); 1288$fptr->set_tscale(5,1.,32768.,$status); 1289$fptr->set_tscale(6,100.,100.,$status); 1290 1291############################ 1292# write data to columns # 1293############################ 1294 1295@$joutarray = (0,1000,10000,32768,65535); 1296 1297for ($ii=4;$ii<7;$ii++) { 1298 $fptr->write_col_lng($ii,1,1,5,$joutarray,$status); 1299 ($status == NUM_OVERFLOW) and print("Overflow writing to column $ii\n"),$status=0; 1300 $fptr->write_col_null($ii,6,1,1,$status); 1301} 1302 1303for ($jj=4;$jj<7;$jj++) { 1304 $fptr->read_col_lng($jj,1,1,6,-999,$jinarray,$anynull,$status); 1305 for ($ii=0;$ii<6;$ii++) { 1306 printf " %6d",$jinarray->[$ii]; 1307 } 1308 print "\n"; 1309} 1310 1311print "\n"; 1312$fptr->set_tscale(4,1.,0.,$status); 1313$fptr->set_tscale(5,1.,0.,$status); 1314$fptr->set_tscale(6,1.,0.,$status); 1315 1316for ($jj=4;$jj<7;$jj++) { 1317 $fptr->read_col_lng($jj,1,1,6,-999,$jinarray,$anynull,$status); 1318 for ($ii=0;$ii<6;$ii++) { 1319 printf " %6d",$jinarray->[$ii]; 1320 } 1321 print "\n"; 1322} 1323 1324###################################################### 1325# insert image extension following the binary table # 1326###################################################### 1327 1328$bitpix=-32; 1329$naxis=2; 1330$naxes=[15,25]; 1331$fptr->insert_img($bitpix,$naxis,$naxes,$status); 1332print "\nCreate image extension: ffiimg status = $status\n"; 1333print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 1334 1335for ($jj=0;$jj<30;$jj++) { 1336 for ($ii=0;$ii<19;$ii++) { 1337 $imgarray->[$jj]->[$ii] = ($ii<15) ? ($jj * 10) + $ii : 0; 1338 } 1339} 1340 1341$fptr->write_2d_sht(1,19,$naxes->[0],$naxes->[1],$imgarray,$status); 1342print "\nWrote whole 2D array: ffp2di status = $status\n"; 1343 1344for ($jj=0;$jj<30;$jj++) { 1345 @{$imgarray->[$jj]} = map(0,(0..18)); 1346} 1347 1348$fptr->read_2d_sht(1,0,19,$naxes->[0],$naxes->[1],$imgarray,$anynull,$status); 1349print "\nRead whole 2D array: ffg2di status = $status\n"; 1350 1351for ($jj=0;$jj<30;$jj++) { 1352 @{$imgarray->[$jj]}[15..18] = (0,0,0,0); 1353 for ($ii=0;$ii<19;$ii++) { 1354 printf " %3d", $imgarray->[$jj]->[$ii]; 1355 } 1356 print "\n"; 1357} 1358 1359for ($jj=0;$jj<30;$jj++) { 1360 @{$imgarray->[$jj]} = map(0,(0..18)); 1361} 1362 1363for ($jj=0;$jj<20;$jj++) { 1364 @{$imgarray2->[$jj]} = map(($jj * -10 - $_),(0..9)); 1365} 1366 1367$fpixels=[5,5]; 1368$lpixels = [14,14]; 1369$fptr->write_subset_sht(1,$naxis,$naxes,$fpixels,$lpixels,$imgarray2,$status); 1370print "\nWrote subset 2D array: ffpssi status = $status\n"; 1371 1372$fptr->read_2d_sht(1,0,19,$naxes->[0],$naxes->[1],$imgarray,$anynull,$status); 1373print "\nRead whole 2D array: ffg2di status = $status\n"; 1374 1375for ($jj=0;$jj<30;$jj++) { 1376 @{$imgarray->[$jj]}[15..18] = (0,0,0,0); 1377 for ($ii=0;$ii<19;$ii++) { 1378 printf " %3d", $imgarray->[$jj]->[$ii]; 1379 } 1380 print "\n"; 1381} 1382 1383$fpixels = [2,5]; 1384$lpixels = [10,8]; 1385$inc = [2,3]; 1386 1387for ($jj=0;$jj<30;$jj++) { 1388 @{$imgarray->[$jj]} = map(0,(0..18)); 1389} 1390 1391$fptr->read_subset_sht(1,$naxis,$naxes,$fpixels,$lpixels,$inc,0,$imgarray->[0],$anynull,$status); 1392print "\nRead subset of 2D array: ffgsvi status = $status\n"; 1393 1394for ($ii=0;$ii<10;$ii++) { 1395 printf " %3d",$imgarray->[0]->[$ii]; 1396} 1397print "\n"; 1398 1399########################################################### 1400# insert another image extension # 1401# copy the image extension to primary array of tmp file. # 1402# then delete the tmp file, and the image extension # 1403########################################################### 1404 1405$bitpix=16; 1406$naxis=2; 1407$naxes = [15,25]; 1408$fptr->insert_img($bitpix,$naxis,$naxes,$status); 1409print "\nCreate image extension: ffiimg status = $status\n"; 1410print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 1411 1412$filename = 't1q2s3v4.tmp'; 1413$tmpfptr=Astro::FITS::CFITSIO::create_file($filename,$status); 1414print "Create temporary file: ffinit status = $status\n"; 1415 1416$fptr->copy_hdu($tmpfptr,0,$status); 1417print "Copy image extension to primary array of tmp file.\n"; 1418print "ffcopy status = $status\n"; 1419 1420$tmpfptr->read_record(1,$card,$status); 1421print "$card\n"; 1422$tmpfptr->read_record(2,$card,$status); 1423print "$card\n"; 1424$tmpfptr->read_record(3,$card,$status); 1425print "$card\n"; 1426$tmpfptr->read_record(4,$card,$status); 1427print "$card\n"; 1428$tmpfptr->read_record(5,$card,$status); 1429print "$card\n"; 1430$tmpfptr->read_record(6,$card,$status); 1431print "$card\n"; 1432 1433$tmpfptr->delete_file($status); 1434print "Delete the tmp file: ffdelt status = $status\n"; 1435 1436$fptr->delete_hdu($hdutype,$status); 1437print "Delete the image extension; hdutype, status = $hdutype $status\n"; 1438print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 1439 1440########################################################### 1441# append bintable extension with variable length columns # 1442########################################################### 1443 1444$fptr->create_hdu($status); 1445print "ffcrhd status = $status\n"; 1446 1447$tform = [ qw( 1PA 1PL 1PB 1PB 1PI 1PJ 1PE 1PD 1PC 1PM ) ]; 1448$ttype = [ qw( Avalue Lvalue Xvalue Bvalue Ivalue Jvalue Evalue Dvalue Cvalue Mvalue ) ]; 1449$tunit = [ ( '', 'm**2', 'cm', 'erg/s', 'km/s', '', '', '', '', '' ) ]; 1450 1451$nrows=20; 1452$tfields = 10; 1453$pcount=0; 1454 1455$fptr->write_btblhdr($nrows,$tfields,$ttype,$tform,$tunit,$binname,$pcount,$status); 1456print "Variable length arrays: ffphbn status = $status\n"; 1457 1458$extvers=4; 1459$fptr->write_key_lng('EXTVER',$extvers,'extension version number',$status); 1460 1461$fptr->write_key_lng('TNULL4', 88, 'value for undefined pixels', $status); 1462$fptr->write_key_lng('TNULL5', 88, 'value for undefined pixels', $status); 1463$fptr->write_key_lng('TNULL6', 88, 'value for undefined pixels', $status); 1464 1465############################ 1466# write data to columns # 1467############################ 1468 1469$iskey = 'abcdefghijklmnopqrst'; 1470 1471@tmp = (1..20); 1472@{$boutarray} = @tmp; 1473@{$ioutarray} = @tmp; 1474@{$joutarray} = @tmp; 1475@{$eoutarray} = @tmp; 1476@{$doutarray} = @tmp; 1477 1478$larray = [0,1,0,0,1,1,0,0,0,1,1,1,0,0,0,0,1,1,1,1]; 1479 1480$inskey=['']; 1481$fptr->write_col_str(1,1,1,1,$inskey,$status); 1482$fptr->write_col_log(2,1,1,1,$larray,$status); 1483$fptr->write_col_bit(3,1,1,1,$larray,$status); 1484$fptr->write_col_byt(4,1,1,1,$boutarray,$status); 1485$fptr->write_col_sht(5,1,1,1,$ioutarray,$status); 1486$fptr->write_col_lng(6,1,1,1,$joutarray,$status); 1487$fptr->write_col_flt(7,1,1,1,$eoutarray,$status); 1488$fptr->write_col_dbl(8,1,1,1,$doutarray,$status); 1489 1490for ($ii=2;$ii<=20;$ii++) { 1491 $inskey->[0] = $iskey; 1492 $inskey->[0] = substr($inskey->[0],0,$ii); 1493 $fptr->write_col_str(1,$ii,1,1,$inskey,$status); 1494 1495 $fptr->write_col_log(2,$ii,1,$ii,$larray,$status); 1496 $fptr->write_col_null(2,$ii,$ii-1,1,$status); 1497 1498 $fptr->write_col_bit(3,$ii,1,$ii,$larray,$status); 1499 1500 $fptr->write_col_byt(4,$ii,1,$ii,$boutarray,$status); 1501 $fptr->write_col_null(4,$ii,$ii-1,1,$status); 1502 1503 $fptr->write_col_sht(5,$ii,1,$ii,$ioutarray,$status); 1504 $fptr->write_col_null(5,$ii,$ii-1,1,$status); 1505 1506 $fptr->write_col_lng(6,$ii,1,$ii,$joutarray,$status); 1507 $fptr->write_col_null(6,$ii,$ii-1,1,$status); 1508 1509 $fptr->write_col_flt(7,$ii,1,$ii,$eoutarray,$status); 1510 $fptr->write_col_null(7,$ii,$ii-1,1,$status); 1511 1512 $fptr->write_col_dbl(8,$ii,1,$ii,$doutarray,$status); 1513 $fptr->write_col_null(8,$ii,$ii-1,1,$status); 1514} 1515print "ffpcl_ status = $status\n"; 1516 1517################################# 1518# close then reopen this HDU # 1519################################# 1520 1521$fptr->movrel_hdu(-1,$hdutype,$status); 1522$fptr->movrel_hdu(1,$hdutype,$status); 1523 1524############################# 1525# read data from columns # 1526############################# 1527 1528$fptr->read_key_lng('PCOUNT',$pcount,$comm,$status); 1529print "PCOUNT = $pcount\n"; 1530 1531$inskey->[0] = ' '; 1532$iskey = ' '; 1533 1534print "HDU number = ${\($fptr->get_hdu_num($hdunum))}\n"; 1535for ($ii=1;$ii<=20;$ii++) { 1536 @tmp = map(0,(0..$ii-1)); 1537 @$larray = @tmp; 1538 @$boutarray = @tmp; 1539 @$ioutarray = @tmp; 1540 @$joutarray = @tmp; 1541 @$eoutarray = @tmp; 1542 @$doutarray = @tmp; 1543 1544 $fptr->read_col_str(1,$ii,1,1,$iskey,$inskey,$anynull,$status); 1545 print "A $inskey->[0] $status\nL"; 1546 1547 $fptr->read_col_log(2,$ii,1,$ii,0,$larray,$anynull,$status); 1548 foreach (0..$ii-1) { 1549 printf " %2d", $larray->[$_]; 1550 } 1551 print " $status\nX"; 1552 1553 $fptr->read_col_bit(3,$ii,1,$ii,$larray,$status); 1554 foreach (0..$ii-1) { 1555 printf " %2d", $larray->[$_]; 1556 } 1557 print " $status\nB"; 1558 1559 $fptr->read_col_byt(4,$ii,1,$ii,99,$boutarray,$anynull,$status); 1560 foreach (0..$ii-1) { 1561 printf " %2d", $boutarray->[$_]; 1562 } 1563 print " $status\nI"; 1564 1565 $fptr->read_col_sht(5,$ii,1,$ii,99,$ioutarray,$anynull,$status); 1566 foreach (0..$ii-1) { 1567 printf " %2d", $ioutarray->[$_]; 1568 } 1569 print " $status\nJ"; 1570 1571 $fptr->read_col_lng(6,$ii,1,$ii,99,$joutarray,$anynull,$status); 1572 foreach (0..$ii-1) { 1573 printf " %2d", $joutarray->[$_]; 1574 } 1575 print " $status\nE"; 1576 1577 $fptr->read_col_flt(7,$ii,1,$ii,99,$eoutarray,$anynull,$status); 1578 foreach (0..$ii-1) { 1579 printf " %2.0f", $eoutarray->[$_]; 1580 } 1581 print " $status\nD"; 1582 1583 $fptr->read_col_dbl(8,$ii,1,$ii,99,$doutarray,$anynull,$status); 1584 foreach (0..$ii-1) { 1585 printf " %2.0f", $doutarray->[$_]; 1586 } 1587 print " $status\n"; 1588 1589 $fptr->read_descript(8,$ii,$repeat,$offset,$status); 1590 print "Column 8 repeat and offset = $repeat $offset\n"; 1591} 1592 1593##################################### 1594# create another image extension # 1595##################################### 1596 1597$bitpix=32; 1598$naxis=2; 1599$naxes=[10,2]; 1600$npixels=20; 1601 1602$fptr->insert_img($bitpix,$naxis,$naxes,$status); 1603print "\nffcrim status = $status\n"; 1604 1605@tmp = map(($_*2),(0..$npixels-1)); 1606@$boutarray = @tmp; 1607@$ioutarray = @tmp; 1608@$joutarray = @tmp; 1609@$koutarray = @tmp; 1610@$eoutarray = @tmp; 1611@$doutarray = @tmp; 1612 1613$fptr->write_img(TBYTE, 1, 2, [@{$boutarray}[0..1]], $status); 1614$fptr->write_img(TSHORT, 3, 2,[ @{$ioutarray}[2..3]], $status); 1615$fptr->write_img(TINT, 5, 2, [@{$koutarray}[4..5]], $status); 1616$fptr->write_img(TSHORT, 7, 2, [@{$ioutarray}[6..7]], $status); 1617$fptr->write_img(TLONG, 9, 2, [@{$joutarray}[8..9]], $status); 1618$fptr->write_img(TFLOAT, 11, 2, [@{$eoutarray}[10..11]], $status); 1619$fptr->write_img(TDOUBLE, 13, 2, [@{$doutarray}[12..13]], $status); 1620print "ffppr status = $status\n"; 1621 1622$bnul=0; 1623$inul=0; 1624$knul=0; 1625$jnul=0; 1626$enul=0.0; 1627$dnul=0.0; 1628 1629$fptr->read_img(TBYTE,1,14,$bnul,$binarray,$anynull,$status); 1630$fptr->read_img(TSHORT,1,14,$inul,$iinarray,$anynull,$status); 1631$fptr->read_img(TINT,1,14,$knul,$kinarray,$anynull,$status); 1632$fptr->read_img(TLONG,1,14,$jnul,$jinarray,$anynull,$status); 1633$fptr->read_img(TFLOAT,1,14,$enul,$einarray,$anynull,$status); 1634$fptr->read_img(TDOUBLE,1,14,$dnul,$dinarray,$anynull,$status); 1635 1636print "\nImage values written with ffppr and read with ffgpv:\n"; 1637 1638$npixels=14; 1639foreach (0..$npixels-1) { printf " %2d", $binarray->[$_] }; print " $anynull (byte)\n"; 1640foreach (0..$npixels-1) { printf " %2d", $iinarray->[$_] }; print " $anynull (short)\n"; 1641foreach (0..$npixels-1) { printf " %2d", $kinarray->[$_] }; print " $anynull (int)\n"; 1642foreach (0..$npixels-1) { printf " %2d", $jinarray->[$_] }; print " $anynull (long)\n"; 1643foreach (0..$npixels-1) { printf " %2.0f", $einarray->[$_] }; print " $anynull (float)\n"; 1644foreach (0..$npixels-1) { printf " %2.0f", $dinarray->[$_] }; print " $anynull (double)\n"; 1645 1646########################################## 1647# test world coordinate system routines # 1648########################################## 1649 1650$xrval=45.83; 1651$yrval=63.57; 1652$xrpix=256.0; 1653$yrpix=257.0; 1654$xinc = -.00277777; 1655$yinc = .00277777; 1656 1657$fptr->write_key_dbl('CRVAL1',$xrval,10,'comment',$status); 1658$fptr->write_key_dbl('CRVAL2',$yrval,10,'comment',$status); 1659$fptr->write_key_dbl('CRPIX1',$xrpix,10,'comment',$status); 1660$fptr->write_key_dbl('CRPIX2',$yrpix,10,'comment',$status); 1661$fptr->write_key_dbl('CDELT1',$xinc,10,'comment',$status); 1662$fptr->write_key_dbl('CDELT2',$yinc,10,'comment',$status); 1663$fptr->write_key_str('CTYPE1',$xcoordtype,'comment',$status); 1664$fptr->write_key_str('CTYPE2',$ycoordtype,'comment',$status); 1665print "\nWrote WCS keywords status = $status\n"; 1666 1667$xrval = 0; 1668$yrval = 0; 1669$xrpix = 0; 1670$yrpix = 0; 1671$xinc = 0; 1672$yinc = 0; 1673$rot = 0; 1674 1675$fptr->read_img_coord($xrval,$yrval,$xrpix,$yrpix,$xinc,$yinc,$rot,$ctype,$status); 1676print "Read WCS keywords with ffgics status = $status\n"; 1677 1678$xpix = 0.5; 1679$ypix = 0.5; 1680 1681fits_pix_to_world($xpix,$ypix,$xrval,$yrval,$xrpix,$yrpix,$xinc,$yinc,$rot,$ctype,$xpos,$ypos,$status); 1682 1683printf " CRVAL1, CRVAL2 = %16.12f, %16.12f\n", $xrval,$yrval; 1684printf " CRPIX1, CRPIX2 = %16.12f, %16.12f\n", $xrpix,$yrpix; 1685printf " CDELT1, CDELT2 = %16.12f, %16.12f\n", $xinc,$yinc; 1686printf " Rotation = %10.3f, CTYPE = $ctype\n", $rot; 1687print "Calculated sky coordinate with ffwldp status = $status\n"; 1688printf " Pixels (%8.4f,%8.4f) --> (%11.6f, %11.6f) Sky\n",$xpix,$ypix,$xpos,$ypos; 1689 1690fits_world_to_pix($xpos,$ypos,$xrval,$yrval,$xrpix,$yrpix,$xinc,$yinc,$rot,$ctype,$xpix,$ypix,$status); 1691print "Calculated pixel coordinate with ffxypx status = $status\n"; 1692printf " Sky (%11.6f, %11.6f) --> (%8.4f,%8.4f) Pixels\n",$xpos,$ypos,$xpix,$ypix; 1693 1694###################################### 1695# append another ASCII table # 1696###################################### 1697 1698$tform = [ qw( A15 I11 F15.6 E13.5 D22.14 ) ]; 1699$ttype = [ qw( Name Ivalue Fvalue Evalue Dvalue ) ]; 1700$tunit = [ ( '', 'm**2', 'cm', 'erg/s', 'km/s' ) ]; 1701 1702$nrows = 11; 1703$tfields = 5; 1704$tblname = 'new_table'; 1705 1706$fptr->create_tbl(ASCII_TBL,$nrows,$tfields,$ttype,$tform,$tunit,$tblname,$status); 1707print "\nffcrtb status = $status\n"; 1708 1709$extvers = 5; 1710$fptr->write_key_lng('EXTVER',$extvers,'extension version number',$status); 1711 1712$fptr->write_col(TSTRING,1,1,1,3,$onskey,$status); 1713 1714@tmp = map(($_*3),(0..$npixels-1)); 1715@$boutarray = @tmp; 1716@$ioutarray = @tmp; 1717@$joutarray = @tmp; 1718@$koutarray = @tmp; 1719@$eoutarray = @tmp; 1720@$doutarray = @tmp; 1721 1722for ($ii=2;$ii<6;$ii++) { 1723 $fptr->write_col(TBYTE,$ii,1,1,2,[@{$boutarray}[0..1]],$status); 1724 $fptr->write_col(TSHORT,$ii,3,1,2,[@{$ioutarray}[2..3]],$status); 1725 $fptr->write_col(TLONG,$ii,5,1,2,[@{$joutarray}[4..5]],$status); 1726 $fptr->write_col(TFLOAT,$ii,7,1,2,[@{$eoutarray}[6..7]],$status); 1727 $fptr->write_col(TDOUBLE,$ii,9,1,2,[@{$doutarray}[8..9]],$status); 1728} 1729print "ffpcl status = $status\n"; 1730 1731$fptr->read_col(TBYTE,2,1,1,10,$bnul,$binarray,$anynull,$status); 1732$fptr->read_col(TSHORT,2,1,1,10,$inul,$iinarray,$anynull,$status); 1733$fptr->read_col(TINT,3,1,1,10,$knul,$kinarray,$anynull,$status); 1734$fptr->read_col(TLONG,3,1,1,10,$jnul,$jinarray,$anynull,$status); 1735$fptr->read_col(TFLOAT,4,1,1,10,$enul,$einarray,$anynull,$status); 1736$fptr->read_col(TDOUBLE,5,1,1,10,$dnul,$dinarray,$anynull,$status); 1737 1738print "\nColumn values written with ffpcl and read with ffgcl:\n"; 1739$npixels = 10; 1740foreach (0..$npixels-1) { printf " %2d",$binarray->[$_] }; print " $anynull (byte)\n"; 1741foreach (0..$npixels-1) { printf " %2d",$iinarray->[$_] }; print " $anynull (short)\n"; 1742foreach (0..$npixels-1) { printf " %2d",$kinarray->[$_] }; print " $anynull (int)\n"; 1743foreach (0..$npixels-1) { printf " %2d",$jinarray->[$_] }; print " $anynull (long)\n"; 1744foreach (0..$npixels-1) { printf " %2.0f",$einarray->[$_] }; print " $anynull (float)\n"; 1745foreach (0..$npixels-1) { printf " %2.0f",$dinarray->[$_] }; print " $anynull (double)\n"; 1746 1747########################################################### 1748# perform stress test by cycling thru all the extensions # 1749########################################################### 1750 1751print "\nRepeatedly move to the 1st 4 HDUs of the file:\n"; 1752for ($ii=0;$ii<10;$ii++) { 1753 $fptr->movabs_hdu(1,$hdutype,$status); 1754 print $fptr->get_hdu_num($hdunum); 1755 $fptr->movrel_hdu(1,$hdutype,$status); 1756 print $fptr->get_hdu_num($hdunum); 1757 $fptr->movrel_hdu(1,$hdutype,$status); 1758 print $fptr->get_hdu_num($hdunum); 1759 $fptr->movrel_hdu(1,$hdutype,$status); 1760 print $fptr->get_hdu_num($hdunum); 1761 $fptr->movrel_hdu(-1,$hdutype,$status); 1762 print $fptr->get_hdu_num($hdunum); 1763 $status and last; 1764} 1765print "\n"; 1766 1767print "Move to extensions by name and version number: (ffmnhd)\n"; 1768$extvers=1; 1769$fptr->movnam_hdu(ANY_HDU,$binname,$extvers,$status); 1770$fptr->get_hdu_num($hdunum); 1771print " $binname, $extvers = hdu $hdunum, $status\n"; 1772 1773$extvers=3; 1774$fptr->movnam_hdu(ANY_HDU,$binname,$extvers,$status); 1775$fptr->get_hdu_num($hdunum); 1776print " $binname, $extvers = hdu $hdunum, $status\n"; 1777 1778$extvers=4; 1779$fptr->movnam_hdu(ANY_HDU,$binname,$extvers,$status); 1780$fptr->get_hdu_num($hdunum); 1781print " $binname, $extvers = hdu $hdunum, $status\n"; 1782 1783 1784$tblname = 'Test-ASCII'; 1785$extvers=2; 1786$fptr->movnam_hdu(ANY_HDU,$tblname,$extvers,$status); 1787$fptr->get_hdu_num($hdunum); 1788print " $tblname, $extvers = hdu $hdunum, $status\n"; 1789 1790$tblname = 'new_table'; 1791$extvers=5; 1792$fptr->movnam_hdu(ANY_HDU,$tblname,$extvers,$status); 1793$fptr->get_hdu_num($hdunum); 1794print " $tblname, $extvers = hdu $hdunum, $status\n"; 1795 1796$extvers=0; 1797$fptr->movnam_hdu(ANY_HDU,$binname,$extvers,$status); 1798$fptr->get_hdu_num($hdunum); 1799print " $binname, $extvers = hdu $hdunum, $status\n"; 1800 1801$extvers=17; 1802$fptr->movnam_hdu(ANY_HDU,$binname,$extvers,$status); 1803$fptr->get_hdu_num($hdunum); 1804print " $binname, $extvers = hdu $hdunum, $status"; 1805 1806print " (expect a 301 error status here)\n"; 1807$status = 0; 1808 1809$fptr->get_num_hdus($hdunum,$status); 1810print "Total number of HDUs in the file = $hdunum\n"; 1811 1812######################## 1813# checksum tests # 1814######################## 1815 1816$checksum=1234567890; 1817fits_encode_chksum($checksum,0,$asciisum); 1818print "\nEncode checksum: $checksum -> $asciisum\n"; 1819$checksum = 0; 1820fits_decode_chksum($asciisum,0,$checksum); 1821print "Decode checksum: $asciisum -> $checksum\n"; 1822 1823$fptr->write_chksum($status); 1824 1825$fptr->read_card('DATASUM',$card,$status); 1826printf "%.30s\n", $card; 1827 1828$fptr->get_chksum($datsum,$checksum,$status); 1829print "ffgcks data checksum, status = $datsum, $status\n"; 1830 1831$fptr->verify_chksum($datastatus,$hdustatus,$status); 1832print "ffvcks datastatus, hdustatus, status = $datastatus $hdustatus $status\n"; 1833 1834$fptr->write_record("new_key = 'written by fxprec' / to change checksum",$status); 1835$fptr->update_chksum($status); 1836print "ffupck status = $status\n"; 1837 1838$fptr->read_card('DATASUM',$card,$status); 1839printf "%.30s\n", $card; 1840$fptr->verify_chksum($datastatus,$hdustatus,$status); 1841print "ffvcks datastatus, hdustatus, status = $datastatus $hdustatus $status\n"; 1842 1843$fptr->delete_key('CHECKSUM',$status); 1844$fptr->delete_key('DATASUM',$status); 1845 1846############################ 1847# close file and quit # 1848############################ 1849 1850ERRSTATUS: { 1851 $fptr->close_file($status); 1852 print "ffclos status = $status\n"; 1853 1854 print "\nNormally, there should be 8 error messages on the stack\n"; 1855 print "all regarding 'numerical overflows':\n"; 1856 1857 fits_read_errmsg($errmsg); 1858 $nmsg = 0; 1859 while (length $errmsg) { 1860 printf " $errmsg\n"; 1861 $nmsg++; 1862 fits_read_errmsg($errmsg); 1863 } 1864 1865 if ($nmsg != 8) { 1866 print "\nWARNING: Did not find the expected 8 error messages!\n"; 1867 } 1868 1869 fits_get_errstatus($status,$errmsg); 1870 print "\nStatus = $status: $errmsg\n"; 1871 1872} 1873