diff options
Diffstat (limited to 'sys/imfort/tasks/phead.f')
| -rw-r--r-- | sys/imfort/tasks/phead.f | 155 |
1 files changed, 155 insertions, 0 deletions
diff --git a/sys/imfort/tasks/phead.f b/sys/imfort/tasks/phead.f new file mode 100644 index 00000000..4a54b584 --- /dev/null +++ b/sys/imfort/tasks/phead.f @@ -0,0 +1,155 @@ +c PHEAD -- Print the header of the named image in FITS format, one keyword +c per line. A pattern may optionally be specified to list some subset of the +c header keywords. +c +c usage: phead image [pattern] +c ---------------------------------------------------------------------------- + + program phead + + character*20 kwname + character*80 image, patstr, errmsg + integer im, kwl, ier + logical sortit + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Get pattern string (list everything if no pattern given). + call clargc (2, patstr, ier) + if (ier .ne. 0) then + patstr = '*' + endif + +c --- Open the image. + call imopen (image, 1, im, ier) + if (ier .ne. 0) goto 91 + +c --- Open the keyword list and print each keyword in FITS format on the +c standard output device. + + sortit = .false. + call imokwl (im, patstr, sortit, kwl, ier) + + 10 continue + call imgnkw (kwl, kwname, ier) + if (ier .ne. 0) goto 20 + call putkey (im, kwname, ier) + if (ier .ne. 0) goto 91 + goto 10 + 20 continue + + call imckwl (kwl, ier) + if (ier .ne. 0) goto 91 + +c --- Clean up. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '(1x, '' Error: '', a80)') errmsg + + stop + end + + +c PUTKEY -- Read the value and comment fields of the named image header +c keyword, and print the value of the keyword in FITS format on the +c standard output device. +c +c 000000000111111111122222222223333333333444444444455555555556 +c 123456789012345678901234567890123456789012345678901234567890 +c keyword = xxx / comment +c keyword = 'sval ' / comment +c +c Datatype codes: 1=bool, 2=char, 3,4,5=int, 6,7=real/double, 8=complex +c Only codes 1, 2, 4, and 6 (bool,char,int,real) are returned by IMTYPK. +c ------------------------------------------------------------------------ + + subroutine putkey (im, kwname, ier) + + integer im + character*(*) kwname + + logical bval + character*68 sval + integer ival + doubleprecision dval + + character*18 valstr + character*47 comstr + character*70 lngstr + integer nchars, dtype, ier, i + +c --- Get the keyword data type and comment information. + call imtypk (im, kwname, dtype, comstr, ier) + if (ier .ne. 0) return + +c --- Print the value of the keyword in FITS format. The format depends +c upon the datatype of the parameter. + + if (dtype .eq. 1) then + call imgkwb (im, kwname, bval, ier) + if (ier .ne. 0) return + write (*, 10) kwname, bval, comstr + 10 format (1x, a8, '= ', l20, ' / ', a47) + + else if (dtype .ge. 3 .and. dtype .le. 5) then + call imgkwi (im, kwname, ival, ier) + if (ier .ne. 0) return + write (*, 20) kwname, ival, comstr + 20 format (1x, a8, '= ', i20, ' / ', a47) + + else if (dtype .eq. 6 .or. dtype .eq. 7) then + call imgkwd (im, kwname, dval, ier) + if (ier .ne. 0) return + if (abs(dval) .lt. 1.0E6 .and. abs(dval) .ge. 1.0E-1) then + write (*, 30) kwname, dval, comstr + 30 format (1x, a8, '= ', f20.2, ' / ', a47) + else + write (*, 31) kwname, dval, comstr + 31 format (1x, a8, '= ', e20.12, ' / ', a47) + endif + + else + call imgkwc (im, kwname, sval, ier) + if (ier .ne. 0) return + + nchars = len(sval) - 1 + do 40 i = nchars, 9, -1 + if (sval(i:i) .ne. ' ') goto 41 + nchars = i - 1 + 40 continue + 41 continue + + if (nchars .le. 8) then + write (*, 45) kwname, sval, comstr + 45 format (1x, a8, '= ''', a8, '''', 10x, ' / ', a47) + else if (nchars .le. 18) then + valstr = sval + write (*, 46) kwname, valstr, comstr + 46 format (1x, a8, '= ''', a18, '''', ' / ', a47) + else + nchars = min (nchars, len(lngstr) - 2) + lngstr(1:1) = '''' + do 47 i = 1, nchars + lngstr(i+1:i+1) = sval(i:i) + 47 continue + lngstr(nchars+2:nchars+2) = '''' + do 48 i = nchars + 3, len(lngstr) + lngstr(i:i) = ' ' + 48 continue + write (*, 49) kwname, lngstr + 49 format (1x, a8, '= ', a69) + endif + endif + + ier = 0 + end |