gdl-astrolib 2018.02.16+dfsg-1 / usr / share / gnudatalanguage / astrolib / sxgpar.pro

function sxgpar,h,par,name,type,sbyte,nbytes
;
;+
; NAME:
;	SXGPAR                           
;
; PURPOSE:
;	Obtain group parameter value in SDAS/FITS file
;
; CALLING SEQUENCE:
;	result = sxgpar( h, par, name, [ type, sbyte, nbytes] )
;
; INPUTS:
;	h - header returned by SXOPEN
;	par - parameter block returned by SXREAD or multiple
;		parameter blocks stored in array of dimension
;		greater than one.
;	name - parameter name (keyword PTYPEn) or integer
;		parameter number.
;
; OPTIONAL INPUT/OUTPUT
;	type - data type (if not supplied or null string, the
;		header is searched for type,sbyte, and nbytes)
;	sbyte - starting byte in parameter block for data
;	nbytes - number of bytes in parameter block for data
;
; OUTPUT:
;	parameter value or value(s) returned as function value
;
; SIDE EFFECTS:
;	If an error occured then !err is set to -1
;
; OPERATIONAL NOTES:
;	Supplying type, sbyte and nbytes greatly decreases execution
;	time.  The best way to get the types is on the first call
;	pass undefined variables for the three parameters or set
;	type = ''.  The routine will then return their values for
;	use in subsequent calls.
;	
; METHOD:
;	The parameter type for parameter n is obtained
;	from PDTYPEn keyword.  If not found then DATATYPE keyword
;	value is used.  If that is not found then BITPIX is
;	used.  BITPIX=8, byte; BITPIX=16 integer*2; BITPIX=32
;	integer*4.
;
; HISTORY:
;	version 1  D. Lindler  Oct. 86
;	version 2  D. Lindler Jan. 90  added ability to process
;		multiple parameter blocks in single call
;	version 3  D. Lindler  (converted to New vaxidl)
;       Apr 14 1991      JKF/ACC - fixed make_array datatypes(float/double)
;	Converted to IDL V5.0   W. Landsman   September 1997
;-
;------------------------------------------------------------
 On_error,2

 if N_params() lt 3 then $
    message,'Syntax - result = sxgpar( h, par, name, [ type, sbyte, nbytes ])'
;
; determine size of output result
;
	s = size(par)
	ndim = s[0]
	dtype = s[ndim+1]
	case 1 of
	    (ndim eq 0) or (dtype ne 1) : begin
			print,'SXGPAR - invalid parameter block specified'	
			return,0
			end
	    ndim eq 1 : begin
			scalar = 1	; output will be scalar
			dimen = intarr(1)+1
			end
	    else: begin
			scalar = 0	; output will be vector
			dimen = s[2:ndim]
		 	end
	endcase
	plen = s[1]		;length of parameter blocks
;
; check if type, sbyte and nbytes supplied
;
	if n_elements(type) ne 0 then if strtrim(type) ne '' then goto,bypass
;
; check remaining input parameters
;
	s=size(h)
	!err=-1
	if (s[0] ne 1) or (s[2] ne 7) then begin
		print,'SXGPAR -- Header array must be string array'
		return,0
	end
	if strlen(h[0]) ne 80 then begin
		print,'SXGPAR -- header must contain 80 character strings'
		return,0
	end
;
	if n_elements(name) eq 0 then begin
		print,'SXGPAR -- parameter name must be a scalar'
 		return,0
	endif
;
; get number of group parameters and size
;
;
	pcount=sxpar(h,'PCOUNT')	;get number of group parameters
	if pcount eq 0 then begin
		print,'sxgpar -- No group parameters present'
		return,0
	endif
	psize=sxpar(h,'PSIZE')	;number of bits in parameter block
	if psize eq 0 then psize=sxpar(h,'BITPIX')*pcount
;
; determine if name supplied or parameter number
;
	s=size(name)
	if s[1] eq 7 then begin	;is it a string?
		nam=strtrim(strupcase(name)) ;convert to upper case and trim
;
; search for parameter name
;
		for i=1,pcount do begin
			if strtrim(sxpar(h,'PTYPE'+strtrim(i,2))) eq nam then $
								goto,found
		endfor
		!err=-1
		print,'SXGPAR -- group parameter ',name,' not found'
		return,0
found:
		ipar=i
	    end else begin		;integer
		ipar=fix(name)
		if ipar gt pcount then begin
			!err=-1
			print,'SXGPAR -- parameter number',name,' is too large'
			print,'       -- only ',pcount,' group parameters'
			return,0
		endif
	endelse
;
; find starting position of parameter in parameter block
;
	nbits=0		;number of bits to skip
	if ipar gt 1 then begin
		for i=1,ipar-1 do begin
			nbit=sxpar(h,'PSIZE'+strtrim(i,2))
			if !err lt 0 then nbit=sxpar(h,'bitpix')
			nbits=nbits+nbit
		endfor
	endif
	sbyte=nbits/8		;number of bytes to skip
;
; determine type of output data
;
	charn=strtrim(ipar,2)	;convert ipar to string
	type=strtrim(sxpar(h,'pdtype'+charn))
	if !err lt 0 then type=strtrim(sxpar(h,'datatype'))
	if !err lt 0 then begin
		case sxpar(h,'bitpix') of
			8: type = 'BYTE'
			16: type = 'INTEGER*2'
			32: type = 'INTEGER*4'
                       -32: type = 'REAL*4'
		endcase
	endif
;
; get number of bytes from type
;
	aster=strpos(type,'*')
	if aster gt 0 then $
		nbytes=fix(strmid(type,aster+1,strlen(type)-aster-1)) $
		else nbytes=4

BYPASS:		
;-------------------------------------------------------------
;
; get first character of type
;
	c=strupcase(strmid(type,0,1))
;
; create output vector
;
	if c eq 'L' then c = 'I'	;change LOGICAL to INTEGER
	case c of
		'R' : if nbytes eq 8 then $
			val = make_array(dimension=dimen,/double) $
			else val = make_array(dimension=dimen,/float)
		'I' : case nbytes of
			1: val=make_array(dimension=dimen,/byte)
			2: val=make_array(dimension=dimen,/int)
			4: val=make_array(dimension=dimen,/long)
		      endcase
		'B' : val = make_array(dimension=dimen,/byte)
		'C' : val = make_array(dimension=dimen,/string)
		else: begin
			print,'sxgpar -- unsupported group parameter data type'
			!err=-1
			return,0
		      end
	endcase
	nval = n_elements(val)
;
; extract data
;
	for i=0,nval-1 do begin
	    ssbyte = sbyte + plen*i
   	    case c of
		'R' : begin
			if nbytes eq 4 then val[i]=float(par,ssbyte)
			if nbytes eq 8 then val[i]=double(par,ssbyte)
		      end
		'I' : begin
			if nbytes eq 1 then val[i]=byte(par,ssbyte)
			if nbytes eq 2 then val[i]=fix(par,ssbyte)
			if nbytes eq 4 then val[i]=long(par,ssbyte)
		      end
		'B' :val=byte(par,ssbyte,1)
		'C' : begin
			val[i]=string(byte(par,ssbyte,nbytes))
		      end
	    endcase
	endfor
;
	if scalar then val=val[0]
	!err=0
	return,val
end