path: root/pkg/xtools/mef/mefrdhdr.x

include <error.h>
include <mach.h>
include <ctype.h> 
include <fset.h>
include <pkg/mef.h>

# MEFRDHR.X -- Routines to read FITS header units.
#
#     eof|stat = mef_rdhdr (mef, group, extname, extver)
# 	         mef_skip_data_unit (mef)
#	totpix = mef_totpix (mef)
#     eof|stat = mef_rdhdr_gn (mef,gn)
#     eof|stat = mef_rdhdr_exnv (mef,extname, extver)


# MEF_RDHR -- Read FITS header on a mef file that matches EXTNAME/EXTVER or 
# GROUP number. If both are specified, the former takes procedence.

int procedure mef_rdhdr (mef, group, extname, extver)

pointer	mef		#I Mef descriptor
int	group 		#I Group number to read
char    extname[ARB]    #I Extname to read		
int	extver		#I Extver to read

int	open(),in, cur_extn, note(), gnum
int	spool
bool	extnv, read_next_group
int	mef_load_header(), mef_pixtype()
bool    mef_cmp_extnv
errchk	open, read, mef_load_header

begin
	if (group == MEF_CGROUP(mef))
	    return (group)

	gnum = group
	if (MEF_FD(mef) == NULL) {
	    MEF_FD(mef) = open (MEF_FNAME(mef), READ_ONLY, BINARY_FILE)
	    MEF_ENUMBER(mef) = -1 
	    MEF_CGROUP(mef) = -1 
	} 
	MEF_SKDATA(mef) = NO  

	in = MEF_FD(mef)

	extnv = extname[1] != EOS || extver != INDEFL
	spool = open ("spool", NEW_FILE, SPOOL_FILE)

	if (gnum == -1 || extnv)
	    gnum = 0
	   
	cur_extn = MEF_CGROUP(mef)
	read_next_group = true

	repeat {
	   # If we need to read the next group
	   if (read_next_group) {

	       cur_extn = cur_extn+1

	       # See if this extension contains the correct 
	       # extname/extver values.

	       call fseti (spool, F_CANCEL, YES)
	       if (mef_load_header (mef, spool, cur_extn) == EOF) {
		   call close (spool)
		   return (EOF)
	       }			

	       # We read the header already, marked the spot.
	       MEF_POFF(mef) = note(in)

	       if (extnv) {
		   read_next_group = mef_cmp_extnv (mef, extname, extver)
	       } else {
		   if (gnum == cur_extn) 
		       read_next_group = false
	       }
	       call mef_skip_data_unit (mef)
	       next

	   } else {			# This is the group we want
	       if (MEF_HDRP(mef) != NULL)
		   call mfree (MEF_HDRP(mef), TY_CHAR)

	       call mef_cp_spool (spool, mef)
	       MEF_CGROUP(mef) = cur_extn

	       # To indicate that data has been skipped.
	       MEF_SKDATA(mef) = YES  
	       break
	   }
	}
	call close (spool)
	MEF_DATATYPE(mef) = mef_pixtype(mef)
	return (cur_extn)
end

int procedure mef_pixtype (mef)
pointer mef, hdrp
bool    bfloat, lscale, lzero
bool    fxf_fpl_equald()
int	i, impixtype, ctod(), ip
double  bscale, bzero
char    sval[LEN_CARD]

begin
        hdrp= MEF_HDRP(mef)
	bscale = 1.0d0
	ip=1
	ifnoerr (call mef_findkw (hdrp, "BSCALE", sval))
	     i = ctod(sval,ip,bscale)
	bzero = 0.0d0
	ip=1
	ifnoerr (call mef_findkw (hdrp, "BZERO", sval))
	     i = ctod(sval,ip,bzero)

	lscale = fxf_fpl_equald (1.0d0, bscale, 1)
	lzero =  fxf_fpl_equald (0.0d0, bzero, 1)

	# Determine if scaling is necessary.
	bfloat = (!lscale || !lzero)

	switch (MEF_BITPIX(mef)) {
	case  8:
	    if (bfloat)
		impixtype = TY_REAL
	    else
		impixtype = TY_SHORT              # convert from byte to short
	case 16:
	    if (bfloat) {
		impixtype = TY_REAL
	    } else
		impixtype = TY_SHORT

	    if (lscale && fxf_fpl_equald (32768.0d0, bzero, 4)) {
		impixtype = TY_USHORT
	    }
	case 32:
	    if (bfloat)
		impixtype = TY_REAL
	    else
		impixtype = TY_INT
	case -32:
	    impixtype = TY_REAL
	case -64:
	    impixtype = TY_DOUBLE
	default:
	    impixtype = ERR
	}

	return(impixtype)

end

# MEF_CMP_EXTNV -- Compare the EXTNAME and EXTVER header values with the
#		  ones passed as arguments. Return false if matched.

bool procedure mef_cmp_extnv (mef, extname, extver)
pointer	mef
char	extname[ARB] 	#I extname value
int	extver		#I extver value

int	mef_strcmp_lwr()
bool	bxtn, bxtv, bval, bxtn_eq, bxtv_eq

begin
	bxtn = extname[1] != EOS
	bxtv = extver != INDEFL

	if (bxtn)
	    bxtn_eq = (mef_strcmp_lwr(MEF_EXTNAME(mef), extname) == 0)
	if (bxtv)
	    bxtv_eq = (MEF_EXTVER(mef) == extver)
	
	if (bxtn && bxtv)
	    # Both EXTNAME and EXTVER are defined.
	    bval = bxtn_eq && bxtv_eq
	else if (bxtn && !bxtv)
	    # Only EXTNAME is defined.
	    bval = bxtn_eq
	else if (!bxtn && bxtv)
	    # Only EXTVER is defined.
	    bval = bxtv_eq 
	else
	    bval = false

	return (!bval)
end

# MEF_SKIP_DATA_UNIT -- Skip data unit. The file is already position at the
# end of the last header block.

procedure mef_skip_data_unit (mef)

pointer	mef	#I Input mef descriptor

int	in, ndim, off, note(), mef_totpix()
errchk  seek

begin
	# See if data portion has already been skipped.
	if (MEF_SKDATA(mef) == YES)
	    return

	in = MEF_FD(mef)
	ndim = MEF_NDIM (mef)
        if (ndim > 0 || MEF_PCOUNT(mef) > 0) {
	   # Skip to the beginning of next extension
	   off = note(in)
	   if (off == EOF)
	      return
	   off = off + mef_totpix(mef)
	   call seek (in, off)
	}
end


# MEF_TOTPIX -- Returns the number of pixels in the data area in units
#		of chars.

int procedure mef_totpix (mef)

pointer	mef		#I Mef descriptor

int	ndim, totpix, i, bitpix

begin
	ndim = MEF_NDIM (mef)
	if (ndim == 0 && MEF_PCOUNT(mef) <= 0)
	    return (0)

	if (ndim == 0)
	    totpix = 0
	else {
	    totpix = MEF_NAXIS(mef,1) 
	    do i = 2, ndim
		  totpix = totpix *  MEF_NAXIS(mef,i)
	}
	bitpix = abs(MEF_BITPIX(mef))

	# If PCOUNT is not zero, add it to totpix
	totpix = MEF_PCOUNT(mef) + totpix

	if (bitpix <= NBITS_BYTE)
	    totpix = (totpix + 1) / SZB_CHAR
	else
	    totpix = totpix * (bitpix / (SZB_CHAR * NBITS_BYTE))

	# Set the number of characters in multiple of 1440.
	totpix = ((totpix + 1439)/1440) * 1440
	return (totpix)
end


# MEF_STRCMP_LWR -- Compare 2 strings in lower case

int procedure mef_strcmp_lwr (s1, s2)

char s1[ARB], s2[ARB]

pointer sp, l1, l2
int	strcmp(), istat

begin
	call smark(sp)
	call salloc (l1, SZ_FNAME, TY_CHAR)
	call salloc (l2, SZ_FNAME, TY_CHAR)

	call strcpy (s1, Memc[l1], SZ_FNAME)
	call strcpy (s2, Memc[l2], SZ_FNAME)
	call strlwr(Memc[l1])
	call strlwr(Memc[l2])
	istat = strcmp (Memc[l1], Memc[l2])

	call sfree(sp)
	return (istat)
end


# MEF_KCTYPE -- Find the type of card that is based on the keyword name.

int procedure mef_kctype (card, index)

char	card[ARB]	#I FITS card
int	index		#O index value

int	strncmp()

begin
	if (strncmp (card, "SIMPLE  ", 8) == 0)
	   return (SIMPLE)
	if (strncmp (card, "NAXIS", 5) == 0) {
	   if (card[6] == ' ') {
	      call mef_gvali (card, index)
	      return (NAXIS)
    	   } else  if (IS_DIGIT(card[6])) {
	       index = TO_INTEG(card[6])
	       return (NAXISN)                      # NAXISn
     	   }
	}
	if (strncmp (card, "BITPIX  ", 8) == 0)
	   return (BITPIX)
	if (strncmp (card, "EXTNAME ", 8) == 0)
	   return (EXTNAME)
	if (strncmp (card, "EXTVER  ", 8) == 0)
	   return (EXTVER)
	if (strncmp (card, "EXTEND  ", 8) == 0)
	   return (EXTEND)
	if (strncmp (card, "PCOUNT  ", 8) == 0)
	   return (PCOUNT)
	if (strncmp (card, "FILENAME", 8) == 0)
	   return (FILENAME)
	if (strncmp (card, "INHERIT ", 8) == 0)
	   return (INHERIT)
	if (strncmp (card, "GCOUNT  ", 8) == 0)
	   return (GCOUNT)
	if (strncmp (card, "OBJECT  ", 8) == 0)
	   return (OBJECT)
	if (strncmp (card, "XTENSION", 8) == 0)
	   return (XTENSION)
	if (strncmp (card, "END     ", 8) == 0)
	   return (END)

        return(ERR)
end


# MEF_RDHDR_GN -- Read group based on group number

int procedure mef_rdhdr_gn (mef,gn)

pointer	mef 		#I mef descriptor
int	gn		#I group number to read

char	extname[MEF_SZVALSTR]
int	extver
int	mef_rdhdr()

errchk  mef_rdhdr

begin
	extname[1] =EOS
	extver=INDEFL
	return (mef_rdhdr (mef, gn, extname, extver))
end


# MEF_RDHDR_EXNV -- Read group based on the Extname and Extver values

int procedure mef_rdhdr_exnv (mef,extname, extver)

pointer	mef		#I, mef descriptor
char	extname[ARB]	#I, extname value
int	extver		#I, extver value
int     mef_rdhdr()

errchk  mef_rdhdr

begin
	return (mef_rdhdr (mef, 0, extname, extver))
end


# MEF_CP_SPOOL -- 

procedure mef_cp_spool (spool, mef)

int	spool 		#I spool file descriptor
pointer mef		#

pointer	hdr, lbuf, sp
int	fitslen, fstatl, user
int	stropen(), getline()

begin
	call smark (sp)
	call salloc (lbuf, SZ_LINE, TY_CHAR)

	call seek (spool, BOFL)
	fitslen = fstatl (spool, F_FILESIZE)
	fitslen = max (fitslen, MEF_HSIZE(mef))
	call malloc (hdr, fitslen, TY_CHAR)
	user = stropen (Memc[hdr], fitslen, NEW_FILE)

	# Append the saved FITS cards to saved cache.
	while (getline (spool, Memc[lbuf]) != EOF)
	    call putline (user, Memc[lbuf])

	call close (user)
	call close (spool)

	MEF_HDRP(mef) = hdr

	call sfree(sp)
end