~ubuntu-branches/debian/stretch/cfitsio/stretch : revision 1

1

program main

2

3

C This is the FITSIO cookbook program that contains an annotated listing of

4

C various computer programs that read and write files in FITS format

5

C using the FITSIO subroutine interface. These examples are

6

C working programs which users may adapt and modify for their own

7

C purposes. This Cookbook serves as a companion to the FITSIO User's

8

C Guide that provides more complete documentation on all the

9

C available FITSIO subroutines.

10

11

C Call each subroutine in turn:

12

13

call writeimage

14

call writeascii

15

call writebintable

16

call copyhdu

17

call selectrows

18

call readheader

19

call readimage

20

call readtable

21

print *

22

print *,"All the fitsio cookbook routines ran successfully."

23

24

end

25

C *************************************************************************

26

subroutine writeimage

27

28

C Create a FITS primary array containing a 2-D image

29

30

integer status,unit,blocksize,bitpix,naxis,naxes(2)

31

integer i,j,group,fpixel,nelements,array(300,200)

32

character filename*80

33

logical simple,extend

34

35

C The STATUS parameter must be initialized before using FITSIO. A

36

C positive value of STATUS is returned whenever a serious error occurs.

37

C FITSIO uses an `inherited status' convention, which means that if a

38

C subroutine is called with a positive input value of STATUS, then the

39

C subroutine will exit immediately, preserving the status value. For

40

C simplicity, this program only checks the status value at the end of

41

C the program, but it is usually better practice to check the status

42

C value more frequently.

43

44

status=0

45

46

C Name of the FITS file to be created:

47

filename='ATESTFILEZ.FITS'

48

49

C Delete the file if it already exists, so we can then recreate it.

50

C The deletefile subroutine is listed at the end of this file.

51

call deletefile(filename,status)

52

53

C Get an unused Logical Unit Number to use to open the FITS file.

54

C This routine is not required; programmers can choose any unused

55

C unit number to open the file.

56

call ftgiou(unit,status)

57

58

C Create the new empty FITS file. The blocksize parameter is a

59

C historical artifact and the value is ignored by FITSIO.

60

blocksize=1

61

call ftinit(unit,filename,blocksize,status)

62

63

C Initialize parameters about the FITS image.

64

C BITPIX = 16 means that the image pixels will consist of 16-bit

65

C integers. The size of the image is given by the NAXES values.

66

C The EXTEND = TRUE parameter indicates that the FITS file

67

C may contain extensions following the primary array.

68

simple=.true.

69

bitpix=16

70

naxis=2

71

naxes(1)=300

72

naxes(2)=200

73

extend=.true.

74

75

C Write the required header keywords to the file

76

call ftphpr(unit,simple,bitpix,naxis,naxes,0,1,extend,status)

77

78

C Initialize the values in the image with a linear ramp function

79

do j=1,naxes(2)

80

do i=1,naxes(1)

81

array(i,j)=i - 1 +j - 1

82

end do

83

end do

84

85

C Write the array to the FITS file.

86

C The last letter of the subroutine name defines the datatype of the

87

C array argument; in this case the 'J' indicates that the array has an

88

C integer*4 datatype. ('I' = I*2, 'E' = Real*4, 'D' = Real*8).

89

C The 2D array is treated as a single 1-D array with NAXIS1 * NAXIS2

90

C total number of pixels. GROUP is seldom used parameter that should

91

C almost always be set = 1.

92

group=1

93

fpixel=1

94

nelements=naxes(1)*naxes(2)

95

call ftpprj(unit,group,fpixel,nelements,array,status)

96

97

C Write another optional keyword to the header

98

C The keyword record will look like this in the FITS file:

99

C

100

C EXPOSURE= 1500 / Total Exposure Time

101

C

102

call ftpkyj(unit,'EXPOSURE',1500,'Total Exposure Time',status)

103

104

C The FITS file must always be closed before exiting the program.

105

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

106

call ftclos(unit, status)

107

call ftfiou(unit, status)

108

109

C Check for any errors, and if so print out error messages.

110

C The PRINTERROR subroutine is listed near the end of this file.

111

if (status .gt. 0)call printerror(status)

112

end

113

C *************************************************************************

114

subroutine writeascii

115

116

C Create an ASCII table containing 3 columns and 6 rows. For convenience,

117

C the ASCII table extension is appended to the FITS image file created

118

C previously by the WRITEIMAGE subroutine.

119

120

integer status,unit,readwrite,blocksize,tfields,nrows,rowlen

121

integer nspace,tbcol(3),diameter(6), colnum,frow,felem

122

real density(6)

123

character filename*40,extname*16

124

character*16 ttype(3),tform(3),tunit(3),name(6)

125

data ttype/'Planet','Diameter','Density'/

126

data tform/'A8','I6','F4.2'/

127

data tunit/' ','km','g/cm'/

128

data name/'Mercury','Venus','Earth','Mars','Jupiter','Saturn'/

129

data diameter/4880,12112,12742,6800,143000,121000/

130

data density/5.1,5.3,5.52,3.94,1.33,0.69/

131

132

C The STATUS parameter must always be initialized.

133

status=0

134

135

C Name of the FITS file to append the ASCII table to:

136

filename='ATESTFILEZ.FITS'

137

138

C Get an unused Logical Unit Number to use to open the FITS file.

139

call ftgiou(unit,status)

140

141

C Open the FITS file with write access.

142

C (readwrite = 0 would open the file with readonly access).

143

readwrite=1

144

call ftopen(unit,filename,readwrite,blocksize,status)

145

146

C FTCRHD creates a new empty FITS extension following the current

147

C extension and moves to it. In this case, FITSIO was initially

148

C positioned on the primary array when the FITS file was first opened, so

149

C FTCRHD appends an empty extension and moves to it. All future FITSIO

150

C calls then operate on the new extension (which will be an ASCII

151

C table).

152

call ftcrhd(unit,status)

153

154

C define parameters for the ASCII table (see the above data statements)

155

tfields=3

156

nrows=6

157

extname='PLANETS_ASCII'

158

159

C FTGABC is a convenient subroutine for calculating the total width of

160

C the table and the starting position of each column in an ASCII table.

161

C Any number of blank spaces (including zero) may be inserted between

162

C each column of the table, as specified by the NSPACE parameter.

163

nspace=1

164

call ftgabc(tfields,tform,nspace,rowlen,tbcol,status)

165

166

C FTPHTB writes all the required header keywords which define the

167

C structure of the ASCII table. NROWS and TFIELDS give the number of

168

C rows and columns in the table, and the TTYPE, TBCOL, TFORM, and TUNIT

169

C arrays give the column name, starting position, format, and units,

170

C respectively of each column. The values of the ROWLEN and TBCOL parameters

171

C were previously calculated by the FTGABC routine.

172

call ftphtb(unit,rowlen,nrows,tfields,ttype,tbcol,tform,tunit,

173

& extname,status)

174

175

C Write names to the first column, diameters to 2nd col., and density to 3rd

176

C FTPCLS writes the string values to the NAME column (column 1) of the

177

C table. The FTPCLJ and FTPCLE routines write the diameter (integer) and

178

C density (real) value to the 2nd and 3rd columns. The FITSIO routines

179

C are column oriented, so it is usually easier to read or write data in a

180

C table in a column by column order rather than row by row.

181

frow=1

182

felem=1

183

colnum=1

184

call ftpcls(unit,colnum,frow,felem,nrows,name,status)

185

colnum=2

186

call ftpclj(unit,colnum,frow,felem,nrows,diameter,status)

187

colnum=3

188

call ftpcle(unit,colnum,frow,felem,nrows,density,status)

189

190

C The FITS file must always be closed before exiting the program.

191

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

192

call ftclos(unit, status)

193

call ftfiou(unit, status)

194

195

C Check for any error, and if so print out error messages.

196

C The PRINTERROR subroutine is listed near the end of this file.

197

if (status .gt. 0)call printerror(status)

198

end

199

C *************************************************************************

200

subroutine writebintable

201

202

C This routine creates a FITS binary table, or BINTABLE, containing

203

C 3 columns and 6 rows. This routine is nearly identical to the

204

C previous WRITEASCII routine, except that the call to FTGABC is not

205

C needed, and FTPHBN is called rather than FTPHTB to write the

206

C required header keywords.

207

208

integer status,unit,readwrite,blocksize,hdutype,tfields,nrows

209

integer varidat,diameter(6), colnum,frow,felem

210

real density(6)

211

character filename*40,extname*16

212

character*16 ttype(3),tform(3),tunit(3),name(6)

213

data ttype/'Planet','Diameter','Density'/

214

data tform/'8A','1J','1E'/

215

data tunit/' ','km','g/cm'/

216

data name/'Mercury','Venus','Earth','Mars','Jupiter','Saturn'/

217

data diameter/4880,12112,12742,6800,143000,121000/

218

data density/5.1,5.3,5.52,3.94,1.33,0.69/

219

220

C The STATUS parameter must always be initialized.

221

status=0

222

223

C Name of the FITS file to append the ASCII table to:

224

filename='ATESTFILEZ.FITS'

225

226

C Get an unused Logical Unit Number to use to open the FITS file.

227

call ftgiou(unit,status)

228

229

C Open the FITS file, with write access.

230

readwrite=1

231

call ftopen(unit,filename,readwrite,blocksize,status)

232

233

C Move to the last (2nd) HDU in the file (the ASCII table).

234

call ftmahd(unit,2,hdutype,status)

235

236

C Append/create a new empty HDU onto the end of the file and move to it.

237

call ftcrhd(unit,status)

238

239

C Define parameters for the binary table (see the above data statements)

240

tfields=3

241

nrows=6

242

extname='PLANETS_BINARY'

243

varidat=0

244

245

C FTPHBN writes all the required header keywords which define the

246

C structure of the binary table. NROWS and TFIELDS gives the number of

247

C rows and columns in the table, and the TTYPE, TFORM, and TUNIT arrays

248

C give the column name, format, and units, respectively of each column.

249

call ftphbn(unit,nrows,tfields,ttype,tform,tunit,

250

& extname,varidat,status)

251

252

C Write names to the first column, diameters to 2nd col., and density to 3rd

253

C FTPCLS writes the string values to the NAME column (column 1) of the

254

C table. The FTPCLJ and FTPCLE routines write the diameter (integer) and

255

C density (real) value to the 2nd and 3rd columns. The FITSIO routines

256

C are column oriented, so it is usually easier to read or write data in a

257

C table in a column by column order rather than row by row. Note that

258

C the identical subroutine calls are used to write to either ASCII or

259

C binary FITS tables.

260

frow=1

261

felem=1

262

colnum=1

263

call ftpcls(unit,colnum,frow,felem,nrows,name,status)

264

colnum=2

265

call ftpclj(unit,colnum,frow,felem,nrows,diameter,status)

266

colnum=3

267

call ftpcle(unit,colnum,frow,felem,nrows,density,status)

268

269

C The FITS file must always be closed before exiting the program.

270

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

271

call ftclos(unit, status)

272

call ftfiou(unit, status)

273

274

C Check for any error, and if so print out error messages.

275

C The PRINTERROR subroutine is listed near the end of this file.

276

if (status .gt. 0)call printerror(status)

277

end

278

C *************************************************************************

279

subroutine copyhdu

280

281

C Copy the 1st and 3rd HDUs from the input file to a new FITS file

282

283

integer status,inunit,outunit,readwrite,blocksize,morekeys,hdutype

284

character infilename*40,outfilename*40

285

286

C The STATUS parameter must always be initialized.

287

status=0

288

289

C Name of the FITS files:

290

infilename='ATESTFILEZ.FITS'

291

outfilename='BTESTFILEZ.FITS'

292

293

C Delete the file if it already exists, so we can then recreate it

294

C The deletefile subroutine is listed at the end of this file.

295

call deletefile(outfilename,status)

296

297

C Get unused Logical Unit Numbers to use to open the FITS files.

298

call ftgiou(inunit,status)

299

call ftgiou(outunit,status)

300

301

C Open the input FITS file, with readonly access

302

readwrite=0

303

call ftopen(inunit,infilename,readwrite,blocksize,status)

304

305

C Create the new empty FITS file (value of blocksize is ignored)

306

blocksize=1

307

call ftinit(outunit,outfilename,blocksize,status)

308

309

C FTCOPY copies the current HDU from the input FITS file to the output

310

C file. The MOREKEY parameter allows one to reserve space for additional

311

C header keywords when the HDU is created. FITSIO will automatically

312

C insert more header space if required, so programmers do not have to

313

C reserve space ahead of time, although it is more efficient to do so if

314

C it is known that more keywords will be appended to the header.

315

morekeys=0

316

call ftcopy(inunit,outunit,morekeys,status)

317

318

C Append/create a new empty extension on the end of the output file

319

call ftcrhd(outunit,status)

320

321

C Skip to the 3rd extension in the input file which in this case

322

C is the binary table created by the previous WRITEBINARY routine.

323

call ftmahd(inunit,3,hdutype,status)

324

325

C FTCOPY now copies the binary table from the input FITS file

326

C to the output file.

327

call ftcopy(inunit,outunit,morekeys,status)

328

329

C The FITS files must always be closed before exiting the program.

330

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

331

C Giving -1 for the value of the first argument causes all previously

332

C allocated unit numbers to be released.

333

334

call ftclos(inunit, status)

335

call ftclos(outunit, status)

336

call ftfiou(-1, status)

337

338

C Check for any error, and if so print out error messages.

339

C The PRINTERROR subroutine is listed near the end of this file.

340

if (status .gt. 0)call printerror(status)

341

end

342

C *************************************************************************

343

subroutine selectrows

344

345

C This routine copies selected rows from an input table into a new output

346

C FITS table. In this example all the rows in the input table that have

347

C a value of the DENSITY column less that 3.0 are copied to the output

348

C table. This program illustrates several generally useful techniques,

349

C including:

350

C how to locate the end of a FITS file

351

C how to create a table when the total number of rows in the table

352

C is not known until the table is completed

353

C how to efficiently copy entire rows from one table to another.

354

355

integer status,inunit,outunit,readwrite,blocksize,hdutype

356

integer nkeys,nspace,naxes(2),nfound,colnum,frow,felem

357

integer noutrows,irow,temp(100),i

358

real nullval,density(6)

359

character infilename*40,outfilename*40,record*80

360

logical exact,anynulls

361

362

C The STATUS parameter must always be initialized.

363

status=0

364

365

C Names of the FITS files:

366

infilename='ATESTFILEZ.FITS'

367

outfilename='BTESTFILEZ.FITS'

368

369

C Get unused Logical Unit Numbers to use to open the FITS files.

370

call ftgiou(inunit,status)

371

call ftgiou(outunit,status)

372

373

C The input FITS file is opened with READONLY access, and the output

374

C FITS file is opened with WRITE access.

375

readwrite=0

376

call ftopen(inunit,infilename,readwrite,blocksize,status)

377

readwrite=1

378

call ftopen(outunit,outfilename,readwrite,blocksize,status)

379

380

C move to the 3rd HDU in the input file (a binary table in this case)

381

call ftmahd(inunit,3,hdutype,status)

382

383

C This do-loop illustrates how to move to the last extension in any FITS

384

C file. The call to FTMRHD moves one extension at a time through the

385

C FITS file until an `End-of-file' status value (= 107) is returned.

386

do while (status .eq. 0)

387

call ftmrhd(outunit,1,hdutype,status)

388

end do

389

390

C After locating the end of the FITS file, it is necessary to reset the

391

C status value to zero and also clear the internal error message stack

392

C in FITSIO. The previous `End-of-file' error will have produced

393

C an unimportant message on the error stack which can be cleared with

394

C the call to the FTCMSG routine (which has no arguments).

395

396

if (status .eq. 107)then

397

status=0

398

call ftcmsg

399

end if

400

401

C Create a new empty extension in the output file.

402

call ftcrhd(outunit,status)

403

404

C Find the number of keywords in the input table header.

405

call ftghsp(inunit,nkeys,nspace,status)

406

407

C This do-loop of calls to FTGREC and FTPREC copies all the keywords from

408

C the input to the output FITS file. Notice that the specified number

409

C of rows in the output table, as given by the NAXIS2 keyword, will be

410

C incorrect. This value will be modified later after it is known how many

411

C rows will be in the table, so it does not matter how many rows are specified

412

C initially.

413

do i=1,nkeys

414

call ftgrec(inunit,i,record,status)

415

call ftprec(outunit,record,status)

416

end do

417

418

C FTGKNJ is used to get the value of the NAXIS1 and NAXIS2 keywords,

419

C which define the width of the table in bytes, and the number of

420

C rows in the table.

421

call ftgknj(inunit,'NAXIS',1,2,naxes,nfound,status)

422

423

C FTGCNO gets the column number of the `DENSITY' column; the column

424

C number is needed when reading the data in the column. The EXACT

425

C parameter determines whether or not the match to the column names

426

C will be case sensitive.

427

exact=.false.

428

call ftgcno(inunit,exact,'DENSITY',colnum,status)

429

430

C FTGCVE reads all 6 rows of data in the `DENSITY' column. The number

431

C of rows in the table is given by NAXES(2). Any null values in the

432

C table will be returned with the corresponding value set to -99

433

C (= the value of NULLVAL). The ANYNULLS parameter will be set to TRUE

434

C if any null values were found while reading the data values in the table.

435

frow=1

436

felem=1

437

nullval=-99.

438

call ftgcve(inunit,colnum,frow,felem,naxes(2),nullval,

439

& density,anynulls,status)

440

441

C If the density is less than 3.0, copy the row to the output table.

442

C FTGTBB and FTPTBB are low-level routines to read and write, respectively,

443

C a specified number of bytes in the table, starting at the specified

444

C row number and beginning byte within the row. These routines do

445

C not do any interpretation of the bytes, and simply pass them to or

446

C from the FITS file without any modification. This is a faster

447

C way of transferring large chunks of data from one FITS file to another,

448

C than reading and then writing each column of data individually.

449

C In this case an entire row of bytes (the row length is specified

450

C by the naxes(1) parameter) is transferred. The datatype of the

451

C buffer array (TEMP in this case) is immaterial so long as it is

452

C declared large enough to hold the required number of bytes.

453

noutrows=0

454

do irow=1,naxes(2)

455

if (density(irow) .lt. 3.0)then

456

noutrows=noutrows+1

457

call ftgtbb(inunit,irow,1,naxes(1),temp,status)

458

call ftptbb(outunit,noutrows,1,naxes(1),temp,status)

459

end if

460

end do

461

462

C Update the NAXIS2 keyword with the correct no. of rows in the output file.

463

C After all the rows have been written to the output table, the

464

C FTMKYJ routine is used to overwrite the NAXIS2 keyword value with

465

C the correct number of rows. Specifying `\&' for the comment string

466

C tells FITSIO to keep the current comment string in the keyword and

467

C only modify the value. Because the total number of rows in the table

468

C was unknown when the table was first created, any value (including 0)

469

C could have been used for the initial NAXIS2 keyword value.

470

call ftmkyj(outunit,'NAXIS2',noutrows,'&',status)

471

472

C The FITS files must always be closed before exiting the program.

473

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

474

call ftclos(inunit, status)

475

call ftclos(outunit, status)

476

call ftfiou(-1, status)

477

478

C Check for any error, and if so print out error messages.

479

C The PRINTERROR subroutine is listed near the end of this file.

480

if (status .gt. 0)call printerror(status)

481

end

482

C *************************************************************************

483

subroutine readheader

484

485

C Print out all the header keywords in all extensions of a FITS file

486

487

integer status,unit,readwrite,blocksize,nkeys,nspace,hdutype,i,j

488

character filename*80,record*80

489

490

C The STATUS parameter must always be initialized.

491

status=0

492

493

C Get an unused Logical Unit Number to use to open the FITS file.

494

call ftgiou(unit,status)

495

496

C name of FITS file

497

filename='ATESTFILEZ.FITS'

498

499

C open the FITS file, with read-only access. The returned BLOCKSIZE

500

C parameter is obsolete and should be ignored.

501

readwrite=0

502

call ftopen(unit,filename,readwrite,blocksize,status)

503

504

j = 0

505

100 continue

506

j = j + 1

507

508

print *,'Header listing for HDU', j

509

510

C The FTGHSP subroutine returns the number of existing keywords in the

511

C current header data unit (CHDU), not counting the required END keyword,

512

call ftghsp(unit,nkeys,nspace,status)

513

514

C Read each 80-character keyword record, and print it out.

515

do i = 1, nkeys

516

call ftgrec(unit,i,record,status)

517

print *,record

518

end do

519

520

C Print out an END record, and a blank line to mark the end of the header.

521

if (status .eq. 0)then

522

print *,'END'

523

print *,' '

524

end if

525

526

C Try moving to the next extension in the FITS file, if it exists.

527

C The FTMRHD subroutine attempts to move to the next HDU, as specified by

528

C the second parameter. This subroutine moves by a relative number of

529

C HDUs from the current HDU. The related FTMAHD routine may be used to

530

C move to an absolute HDU number in the FITS file. If the end-of-file is

531

C encountered when trying to move to the specified extension, then a

532

C status = 107 is returned.

533

call ftmrhd(unit,1,hdutype,status)

534

535

if (status .eq. 0)then

536

C success, so jump back and print out keywords in this extension

537

go to 100

538

539

else if (status .eq. 107)then

540

C hit end of file, so quit

541

status=0

542

end if

543

544

C The FITS file must always be closed before exiting the program.

545

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

546

call ftclos(unit, status)

547

call ftfiou(unit, status)

548

549

C Check for any error, and if so print out error messages.

550

C The PRINTERROR subroutine is listed near the end of this file.

551

if (status .gt. 0)call printerror(status)

552

end

553

C *************************************************************************

554

subroutine readimage

555

556

C Read a FITS image and determine the minimum and maximum pixel value.

557

C Rather than reading the entire image in

558

C at once (which could require a very large array), the image is read

559

C in pieces, 100 pixels at a time.

560

561

integer status,unit,readwrite,blocksize,naxes(2),nfound

562

integer group,firstpix,nbuffer,npixels,i

563

real datamin,datamax,nullval,buffer(100)

564

logical anynull

565

character filename*80

566

567

C The STATUS parameter must always be initialized.

568

status=0

569

570

C Get an unused Logical Unit Number to use to open the FITS file.

571

call ftgiou(unit,status)

572

573

C Open the FITS file previously created by WRITEIMAGE

574

filename='ATESTFILEZ.FITS'

575

readwrite=0

576

call ftopen(unit,filename,readwrite,blocksize,status)

577

578

C Determine the size of the image.

579

call ftgknj(unit,'NAXIS',1,2,naxes,nfound,status)

580

581

C Check that it found both NAXIS1 and NAXIS2 keywords.

582

if (nfound .ne. 2)then

583

print *,'READIMAGE failed to read the NAXISn keywords.'

584

return

585

end if

586

587

C Initialize variables

588

npixels=naxes(1)*naxes(2)

589

group=1

590

firstpix=1

591

nullval=-999

592

datamin=1.0E30

593

datamax=-1.0E30

594

595

do while (npixels .gt. 0)

596

C read up to 100 pixels at a time

597

nbuffer=min(100,npixels)

598

599

call ftgpve(unit,group,firstpix,nbuffer,nullval,

600

& buffer,anynull,status)

601

602

C find the min and max values

603

do i=1,nbuffer

604

datamin=min(datamin,buffer(i))

605

datamax=max(datamax,buffer(i))

606

end do

607

608

C increment pointers and loop back to read the next group of pixels

609

npixels=npixels-nbuffer

610

firstpix=firstpix+nbuffer

611

end do

612

613

print *

614

print *,'Min and max image pixels = ',datamin,datamax

615

616

C The FITS file must always be closed before exiting the program.

617

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

618

call ftclos(unit, status)

619

call ftfiou(unit, status)

620

621

C Check for any error, and if so print out error messages.

622

C The PRINTERROR subroutine is listed near the end of this file.

623

if (status .gt. 0)call printerror(status)

624

end

625

C *************************************************************************

626

subroutine readtable

627

628

C Read and print data values from an ASCII or binary table

629

C This example reads and prints out all the data in the ASCII and

630

C the binary tables that were previously created by WRITEASCII and

631

C WRITEBINTABLE. Note that the exact same FITSIO routines are

632

C used to read both types of tables.

633

634

integer status,unit,readwrite,blocksize,hdutype,ntable

635

integer felem,nelems,nullj,diameter,nfound,irow,colnum

636

real nulle,density

637

character filename*40,nullstr*1,name*8,ttype(3)*10

638

logical anynull

639

640

C The STATUS parameter must always be initialized.

641

status=0

642

643

C Get an unused Logical Unit Number to use to open the FITS file.

644

call ftgiou(unit,status)

645

646

C Open the FITS file previously created by WRITEIMAGE

647

filename='ATESTFILEZ.FITS'

648

readwrite=0

649

call ftopen(unit,filename,readwrite,blocksize,status)

650

651

C Loop twice, first reading the ASCII table, then the binary table

652

do ntable=2,3

653

654

C Move to the next extension

655

call ftmahd(unit,ntable,hdutype,status)

656

657

print *,' '

658

if (hdutype .eq. 1)then

659

print *,'Reading ASCII table in HDU ',ntable

660

else if (hdutype .eq. 2)then

661

print *,'Reading binary table in HDU ',ntable

662

end if

663

664

C Read the TTYPEn keywords, which give the names of the columns

665

call ftgkns(unit,'TTYPE',1,3,ttype,nfound,status)

666

write(*,2000)ttype

667

2000 format(2x,"Row ",3a10)

668

669

C Read the data, one row at a time, and print them out

670

felem=1

671

nelems=1

672

nullstr=' '

673

nullj=0

674

nulle=0.

675

do irow=1,6

676

C FTGCVS reads the NAMES from the first column of the table.

677

colnum=1

678

call ftgcvs(unit,colnum,irow,felem,nelems,nullstr,name,

679

& anynull,status)

680

681

C FTGCVJ reads the DIAMETER values from the second column.

682

colnum=2

683

call ftgcvj(unit,colnum,irow,felem,nelems,nullj,diameter,

684

& anynull,status)

685

686

C FTGCVE reads the DENSITY values from the third column.

687

colnum=3

688

call ftgcve(unit,colnum,irow,felem,nelems,nulle,density,

689

& anynull,status)

690

write(*,2001)irow,name,diameter,density

691

2001 format(i5,a10,i10,f10.2)

692

end do

693

end do

694

695

C The FITS file must always be closed before exiting the program.

696

C Any unit numbers allocated with FTGIOU must be freed with FTFIOU.

697

call ftclos(unit, status)

698

call ftfiou(unit, status)

699

700

C Check for any error, and if so print out error messages.

701

C The PRINTERROR subroutine is listed near the end of this file.

702

if (status .gt. 0)call printerror(status)

703

end

704

C *************************************************************************

705

subroutine printerror(status)

706

707

C This subroutine prints out the descriptive text corresponding to the

708

C error status value and prints out the contents of the internal

709

C error message stack generated by FITSIO whenever an error occurs.

710

711

integer status

712

character errtext*30,errmessage*80

713

714

C Check if status is OK (no error); if so, simply return

715

if (status .le. 0)return

716

717

C The FTGERR subroutine returns a descriptive 30-character text string that

718

C corresponds to the integer error status number. A complete list of all

719

C the error numbers can be found in the back of the FITSIO User's Guide.

720

call ftgerr(status,errtext)

721

print *,'FITSIO Error Status =',status,': ',errtext

722

723

C FITSIO usually generates an internal stack of error messages whenever

724

C an error occurs. These messages provide much more information on the

725

C cause of the problem than can be provided by the single integer error

726

C status value. The FTGMSG subroutine retrieves the oldest message from

727

C the stack and shifts any remaining messages on the stack down one

728

C position. FTGMSG is called repeatedly until a blank message is

729

C returned, which indicates that the stack is empty. Each error message

730

C may be up to 80 characters in length. Another subroutine, called

731

C FTCMSG, is available to simply clear the whole error message stack in

732

C cases where one is not interested in the contents.

733

call ftgmsg(errmessage)

734

do while (errmessage .ne. ' ')

735

print *,errmessage

736

call ftgmsg(errmessage)

737

end do

738

end

739

C *************************************************************************

740

subroutine deletefile(filename,status)

741

742

C A simple little routine to delete a FITS file

743

744

integer status,unit,blocksize

745

character*(*) filename

746

747

C Simply return if status is greater than zero

748

if (status .gt. 0)return

749

750

C Get an unused Logical Unit Number to use to open the FITS file

751

call ftgiou(unit,status)

752

753

C Try to open the file, to see if it exists

754

call ftopen(unit,filename,1,blocksize,status)

755

756

if (status .eq. 0)then

757

C file was opened; so now delete it

758

call ftdelt(unit,status)

759

else if (status .eq. 103)then

760

C file doesn't exist, so just reset status to zero and clear errors

761

status=0

762

call ftcmsg

763

else

764

C there was some other error opening the file; delete the file anyway

765

status=0

766

call ftcmsg

767

call ftdelt(unit,status)

768

end if

769

770

C Free the unit number for later reuse

771

call ftfiou(unit, status)

772

end