SUBROUTINE ASHOW( STATUS )
*+
* Name:
* ASHOW
* Purpose:
* Display attributes of a dataset in text form
* Language:
* Starlink Fortran
* Type of Module:
* ASTERIX task
* Invocation:
* CALL ASHOW( STATUS )
* Arguments:
* STATUS = INTEGER (Given and Returned)
* The global status.
* Description:
* {routine_description}
* Usage:
* ASHOW {parameter_usage}
* Environment Parameters:
* INP = CHAR (Given)
* Name of file object whose attributes are to be displayed
* ITEM = CHAR (Given)
* The attribute to be displayed
* DEV = CHAR (Given)
* The name of the output text device
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* Implementation Status:
* {routine_implementation_status}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* References:
* {task_references}...
* Keywords:
* ashow, usage:public
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 1.8-0 (DJA):
* Original version.
* 14 Aug 1995 1.8-1 (DJA):
* Improved timing report and added links option.
* 6 Sep 1995 2.0-0 (DJA):
* Display selection info
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
* Status:
INTEGER STATUS ! Global status
* External References:
EXTERNAL CHR_INSET
LOGICAL CHR_INSET
* Local Constants:
INTEGER IC_WCS
PARAMETER ( IC_WCS = 1 )
INTEGER IC_MIS
PARAMETER ( IC_MIS = 2 )
INTEGER IC_TIM
PARAMETER ( IC_TIM = 4 )
INTEGER IC_LNK
PARAMETER ( IC_LNK = 8 )
INTEGER IC_SEL
PARAMETER ( IC_SEL = 16 )
INTEGER IC_ALL
PARAMETER ( IC_ALL = IC_WCS+IC_MIS+IC_TIM+IC_LNK+IC_SEL )
CHARACTER*30 VERSION
PARAMETER ( VERSION = 'ASHOW Version 2.0-0' )
* Local Variables:
CHARACTER*200 FILE, PATH ! File path info
CHARACTER*20 ITEM ! Items to display
INTEGER IFID ! Input dataset id
INTEGER ITEMC ! Item code
INTEGER NLEV ! # path levels
INTEGER OCH ! Output channel
INTEGER OUTWID ! Output channel width
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Version id
CALL MSG_PRNT( VERSION )
* Initialise ASTERIX
CALL AST_INIT()
* Open the file
CALL USI_ASSOC( 'INP', '*', 'READ', IFID, STATUS )
* Get item to be displayed
CALL USI_GET0C( 'ITEM', ITEM, STATUS )
IF ( STATUS .EQ. SAI__OK ) THEN
* Check against allowed alternatives
IF ( ITEM .EQ. '*' ) THEN
ITEMC = IC_ALL
* Non-wildcard
ELSE
* World coordinates?
IF ( CHR_INSET( ITEM, 'WCS' ) ) THEN
ITEMC = ITEMC + IC_WCS
ELSE IF ( CHR_INSET( ITEM, 'MISS' ) ) THEN
ITEMC = ITEMC + IC_MIS
ELSE IF ( CHR_INSET( ITEM, 'TIME' ) ) THEN
ITEMC = ITEMC + IC_TIM
ELSE IF ( CHR_INSET( ITEM, 'LINKS' ) ) THEN
ITEMC = ITEMC + IC_LNK
ELSE IF ( CHR_INSET( ITEM, 'SEL' ) ) THEN
ITEMC = ITEMC + IC_SEL
* Otherwise error
ELSE
CALL MSG_SETC( 'ITEM', ITEM )
STATUS = SAI__ERROR
CALL ERR_REP( ' ', 'ASHOW item list contains unrecognised '/
: /'item /^ITEM/, see help for list of valid items', STATUS )
END IF
END IF
END IF
* Open the output channel
CALL AIO_ASSOCO( 'DEV', 'LIST', OCH, OUTWID, STATUS )
* All is well?
IF ( STATUS .EQ. SAI__OK ) THEN
* Write details of file
CALL ADI_FTRACE( IFID, NLEV, PATH, FILE, STATUS )
* Mission strings?
IF ( AND( ITEMC, IC_MIS ) .NE. 0 ) THEN
CALL ASHOW_MIS( IFID, OCH, STATUS )
END IF
* Timing
IF ( AND( ITEMC, IC_TIM ) .NE. 0 ) THEN
CALL ASHOW_TIM( IFID, OCH, STATUS )
END IF
* World coordinates?
IF ( AND( ITEMC, IC_WCS ) .NE. 0 ) THEN
CALL ASHOW_WCS( IFID, OCH, STATUS )
END IF
* File links
IF ( AND( ITEMC, IC_LNK ) .NE. 0 ) THEN
CALL ASHOW_LNK( IFID, OCH, STATUS )
END IF
* Dataset selection
IF ( AND( ITEMC, IC_SEL ) .NE. 0 ) THEN
CALL ASHOW_SEL( IFID, OCH, STATUS )
END IF
END IF
* Close output device
CALL AIO_CANCL( 'DEV', STATUS )
* Tidy up
CALL AST_CLOSE()
CALL AST_ERR( STATUS )
END
SUBROUTINE ASHOW_WCS( IFID, OCH, STATUS )
*+
* Name:
* ASHOW_WCS
* Purpose:
* Display world coordinates data
* Language:
* Starlink Fortran
* Invocation:
* CALL ASHOW_WCS( IFID, OCH, STATUS )
* Description:
* {routine_description}
* Arguments:
* IFID = INTEGER (given)
* Input dataset identifier
* OCH = INTEGER (given)
* Output channel identifier
* STATUS = INTEGER (given and returned)
* The global status.
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* Keywords:
* ashow, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 (DJA):
* Original version.
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
INCLUDE 'ADI_PAR'
INCLUDE 'MATH_PAR'
* Arguments Given:
INTEGER IFID ! Input dataset id
INTEGER OCH ! Output channel
* Status:
INTEGER STATUS ! Global status
* Local Variables:
CHARACTER*1 EFORM ! Form of epoch
CHARACTER*20 RAS, DECS ! RA,DEC in strings
CHARACTER*3 SYS ! Coord system name
DOUBLE PRECISION EPOCH ! Equinox & epoch
DOUBLE PRECISION PNT(2) ! Pointing direction
INTEGER NVAL ! Values read from obj
INTEGER PIXID ! Pixellation
INTEGER PRJID ! Projection
INTEGER SYSID ! Coord system
LOGICAL THERE ! Object exists?
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Load WCS info
CALL WCI_GETIDS( IFID, PIXID, PRJID, SYSID, STATUS )
IF ( STATUS .NE. SAI__OK ) THEN
CALL ERR_ANNUL( STATUS )
END IF
* Write heading
CALL AIO_BLNK( OCH, STATUS )
CALL AIO_IWRITE( OCH, 2, 'World Coordinates :', STATUS )
CALL AIO_BLNK( OCH, STATUS )
* First the coordinate system
CALL AIO_IWRITE( OCH, 4, 'Coordinate system :', STATUS )
CALL AIO_BLNK( OCH, STATUS )
CALL ASHOW_OB( SYSID, 'NAME', 'C', 'System name', ' ',
: 'np', OCH, STATUS )
CALL ASHOW_OB( SYSID, 'EQUINOX', 'D', 'Equinox', ' ',
: 'np', OCH, STATUS )
IF ( SYSID .NE. ADI__NULLID ) THEN
CALL ADI_CGET0C( SYSID, 'EFORM', EFORM, STATUS )
CALL ADI_CGET0D( SYSID, 'EPOCH', EPOCH, STATUS )
CALL MSG_SETC( 'EF', EFORM )
CALL MSG_SETD( 'EP', EPOCH )
CALL AIO_IWRITE( OCH, 6, 'Epoch : ^EF^EP',
: STATUS )
ELSE
CALL AIO_IWRITE( OCH, 6, '* not present *', STATUS )
END IF
CALL AIO_BLNK( OCH, STATUS )
* The projection
CALL AIO_IWRITE( OCH, 4, 'Coordinate reference & projection :',
: STATUS )
CALL AIO_BLNK( OCH, STATUS )
IF ( SYSID .NE. ADI__NULLID ) THEN
* Name of system
CALL ADI_CGET0C( SYSID, 'NAME', SYS, STATUS )
* Name of projection
CALL ASHOW_OB( PRJID, 'NAME', 'C', 'Projection name', ' ',
: 'np', OCH, STATUS )
* Axis origin
CALL ADI_CGET1D( PRJID, 'SPOINT', 2, PNT, NVAL, STATUS )
IF ( SYS(1:2) .EQ. 'FK' ) THEN
CALL STR_DRADTOC( PNT(1)*MATH__DDTOR, 'HHh MMm SS.SSs', RAS,
: STATUS )
CALL STR_DRADTOC( PNT(2)*MATH__DDTOR, 'SDDd MMm SS.Ss',DECS,
: STATUS )
CALL MSG_SETC( 'A', RAS )
CALL MSG_SETC( 'B', DECS )
ELSE
CALL MSG_SETD( 'A', PNT(1) )
CALL MSG_SETD( 'B', PNT(2) )
END IF
CALL AIO_IWRITE( OCH, 6, 'Axis origin : ^A ^B',
: STATUS )
* Centre of f.o.v
CALL ADI_THERE( PRJID, 'NPOINT', THERE, STATUS )
IF ( THERE ) THEN
CALL ADI_CGET1D( PRJID, 'NPOINT', 2, PNT, NVAL, STATUS )
IF ( SYS(1:2) .EQ. 'FK' ) THEN
CALL STR_DRADTOC( PNT(1)*MATH__DDTOR, 'HHh MMm SS.SSs', RAS,
: STATUS )
CALL STR_DRADTOC( PNT(2)*MATH__DDTOR, 'SDDd MMm SS.Ss',
: DECS, STATUS )
CALL MSG_SETC( 'A', RAS )
CALL MSG_SETC( 'B', DECS )
ELSE
CALL MSG_SETD( 'A', PNT(1) )
CALL MSG_SETD( 'B', PNT(2) )
END IF
CALL AIO_IWRITE( OCH, 6, 'FOV position : ^A ^B',
: STATUS )
END IF
ELSE
CALL AIO_IWRITE( OCH, 6, '* not present *', STATUS )
END IF
CALL AIO_BLNK( OCH, STATUS )
* Report any errors
IF ( STATUS .NE. SAI__OK ) CALL AST_REXIT( 'ASHOW_WCS', STATUS )
END
SUBROUTINE ASHOW_MIS( IFID, OCH, STATUS )
*+
* Name:
* ASHOW_MIS
* Purpose:
* Display detector configuration info
* Language:
* Starlink Fortran
* Invocation:
* CALL ASHOW_MIS( IFID, OCH, STATUS )
* Description:
* {routine_description}
* Arguments:
* IFID = INTEGER (given)
* Input dataset identifier
* OCH = INTEGER (given)
* Output channel identifier
* STATUS = INTEGER (given and returned)
* The global status.
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* Keywords:
* ashow, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 (DJA):
* Original version.
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
INCLUDE 'ADI_PAR'
* Arguments Given:
INTEGER IFID ! Input dataset id
INTEGER OCH ! Output channel
* Status:
INTEGER STATUS ! Global status
* Local Variables:
INTEGER DETID ! DCI info
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Load mission strings
CALL DCI_GETID( IFID, DETID, STATUS )
IF ( STATUS .NE. SAI__OK ) THEN
CALL ERR_ANNUL( STATUS )
END IF
* Write heading
CALL AIO_BLNK( OCH, STATUS )
CALL AIO_IWRITE( OCH, 2, 'Mission Description Strings :', STATUS )
CALL AIO_BLNK( OCH, STATUS )
* The observation details
CALL AIO_IWRITE( OCH, 4, 'Observation Details :', STATUS )
CALL AIO_BLNK( OCH, STATUS )
CALL ASHOW_OB( DETID, 'Observer', 'C', 'Observer', ' ',
: 'ig', OCH, STATUS )
CALL ASHOW_OB( DETID, 'Target', 'C', 'Target', ' ',
: 'ig', OCH, STATUS )
CALL AIO_BLNK( OCH, STATUS )
* The hardware
CALL AIO_IWRITE( OCH, 4, 'Instrument Configuration :', STATUS )
CALL AIO_BLNK( OCH, STATUS )
CALL ASHOW_OB( DETID, 'Mission', 'C', 'Mission', ' ',
: 'ig', OCH, STATUS )
CALL ASHOW_OB( DETID, 'Instrument', 'C', 'Instrument', ' ',
: 'ig', OCH, STATUS )
CALL ASHOW_OB( DETID, 'Detector', 'C', 'Detector', ' ',
: 'ig', OCH, STATUS )
CALL ASHOW_OB( DETID, 'Filter', 'C', 'Filter', ' ',
: 'ig', OCH, STATUS )
CALL ASHOW_OB( DETID, 'DataMode', 'C', 'Data mode', ' ',
: 'ig', OCH, STATUS )
CALL AIO_BLNK( OCH, STATUS )
* Report any errors
IF ( STATUS .NE. SAI__OK ) CALL AST_REXIT( 'ASHOW_MIS', STATUS )
END
SUBROUTINE ASHOW_TIM( IFID, OCH, STATUS )
*+
* Name:
* ASHOW_TIM
* Purpose:
* Display timing info
* Language:
* Starlink Fortran
* Invocation:
* CALL ASHOW_TIM( IFID, OCH, STATUS )
* Description:
* {routine_description}
* Arguments:
* IFID = INTEGER (given)
* Input dataset identifier
* OCH = INTEGER (given)
* Output channel identifier
* STATUS = INTEGER (given and returned)
* The global status.
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* Keywords:
* ashow, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 (DJA):
* Original version.
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
INCLUDE 'ADI_PAR'
* Arguments Given:
INTEGER IFID ! Input dataset id
INTEGER OCH ! Output channel
* Status:
INTEGER STATUS ! Global status
* Local Variables:
CHARACTER*8 DSTR, TSTR ! Date and time
DOUBLE PRECISION MJD ! MJD at start
INTEGER TIMID ! TCI info
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Load timing info
CALL TCI_GETID( IFID, TIMID, STATUS )
IF ( STATUS .NE. SAI__OK ) THEN
CALL ERR_ANNUL( STATUS )
END IF
* Write heading
CALL AIO_BLNK( OCH, STATUS )
CALL AIO_IWRITE( OCH, 2, 'Timing Information :', STATUS )
CALL AIO_BLNK( OCH, STATUS )
* The observation details
CALL AIO_IWRITE( OCH, 4, 'Observation Dates & Exposure Times :',
: STATUS )
CALL AIO_BLNK( OCH, STATUS )
CALL ADI_CGET0D( TIMID, 'MJDObs', MJD, STATUS )
IF ( STATUS .EQ. SAI__OK ) THEN
CALL TCI_MJD2DT( MJD, DSTR, TSTR, STATUS )
CALL ASHOW_VAL( DSTR//' '//TSTR, 'Date/time at start', ' ',
: OCH, STATUS )
ELSE
CALL ERR_ANNUL( STATUS )
END IF
CALL ASHOW_OB( TIMID, 'MJDObs', 'D', 'MJD at start', ' ',
: 'np', OCH, STATUS )
CALL ASHOW_OB( TIMID, 'TAIObs', 'C', 'TAI at start', 'days',
: 'np', OCH, STATUS )
CALL ASHOW_OB( TIMID, 'ObsLength', 'R', 'Obs. length', 'seconds',
: 'np', OCH, STATUS )
CALL ASHOW_OB( TIMID, 'Exposure', 'R', 'Exposure', 'seconds',
: 'np', OCH, STATUS )
CALL ASHOW_OB( TIMID, 'EffExposure', 'R', 'Effective exposure',
: 'seconds', 'ig', OCH, STATUS )
CALL AIO_BLNK( OCH, STATUS )
* Report any errors
IF ( STATUS .NE. SAI__OK ) CALL AST_REXIT( 'ASHOW_TIM', STATUS )
END
SUBROUTINE ASHOW_LNK( IFID, OCH, STATUS )
*+
* Name:
* ASHOW_LNK
* Purpose:
* Display file links
* Language:
* Starlink Fortran
* Invocation:
* CALL ASHOW_TIM( IFID, OCH, STATUS )
* Description:
* {routine_description}
* Arguments:
* IFID = INTEGER (given)
* Input dataset identifier
* OCH = INTEGER (given)
* Output channel identifier
* STATUS = INTEGER (given and returned)
* The global status.
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* Keywords:
* ashow, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 (DJA):
* Original version.
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
INCLUDE 'ADI_PAR'
* Arguments Given:
INTEGER IFID ! Input dataset id
INTEGER OCH ! Output channel
* Status:
INTEGER STATUS ! Global status
* External References:
EXTERNAL CHR_LEN
INTEGER CHR_LEN
* Local Constants:
INTEGER NLINK
PARAMETER ( NLINK = 2 )
* Local Variables:
CHARACTER*4 LNAMS(NLINK) ! Link names
CHARACTER*40 LDESC(NLINK) ! Link descriptions
CHARACTER*132 LINK ! Link value
INTEGER I ! Loop over links
INTEGER L ! Length of an LNAMS
LOGICAL OK ! Link is present
* Local Data:
DATA LNAMS/'BGND', 'VIGN'/
DATA LDESC/'Background dataset',
: 'Vignetting factors'/
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Write heading
CALL AIO_BLNK( OCH, STATUS )
CALL AIO_IWRITE( OCH, 2, 'File link information :', STATUS )
CALL AIO_BLNK( OCH, STATUS )
* Write each link
DO I = 1, NLINK
* Link is present
L = CHR_LEN( LNAMS(I) )
CALL FRI_CHK( IFID, LNAMS(I)(:L), OK, STATUS )
IF ( OK ) THEN
CALL FRI_GETC( IFID, LNAMS(I)(:L), LINK, STATUS )
CALL ASHOW_VAL( LINK, LDESC(I), ' ', OCH, STATUS )
ELSE
CALL ASHOW_VAL( '* not set *', LDESC(I), ' ', OCH, STATUS )
END IF
END DO
* Report any errors
IF ( STATUS .NE. SAI__OK ) CALL AST_REXIT( 'ASHOW_LNK', STATUS )
END
SUBROUTINE ASHOW_SEL( IFID, OCH, STATUS )
*+
* Name:
* ASHOW_SEL
* Purpose:
* Display data selection
* Language:
* Starlink Fortran
* Invocation:
* CALL ASHOW_SEL( IFID, OCH, STATUS )
* Description:
* {routine_description}
* Arguments:
* IFID = INTEGER (given)
* Input dataset identifier
* OCH = INTEGER (given)
* Output channel identifier
* STATUS = INTEGER (given and returned)
* The global status.
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* Keywords:
* ashow, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 (DJA):
* Original version.
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
INCLUDE 'ADI_PAR'
* Arguments Given:
INTEGER IFID ! Input dataset id
INTEGER OCH ! Output channel
* Status:
INTEGER STATUS ! Global status
* External References:
EXTERNAL CHR_LEN
INTEGER CHR_LEN
* Local Variables:
CHARACTER*132 ARDIN ! ARD text
CHARACTER*40 CREATOR ! Selection author
CHARACTER*20 SNAME ! Selection name
CHARACTER*20 VARIANT ! Selector variant
REAL START, STOP ! Range pair
INTEGER BPTR, EPTR ! Mapped range pairs
INTEGER GRPID ! ARD identifier
INTEGER I ! Loop over selections
INTEGER ICMP ! Loop over selectors
INTEGER ITXT ! Loop over ARD text
INTEGER L ! Length of ARDIN used
INTEGER NCMP ! # selectors
INTEGER NREC ! # selection records
INTEGER SELID ! Selection identifier
INTEGER SIID ! Selector identifier
INTEGER SID ! Selectors structure
INTEGER SIZE ! Amount of sel data
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Write heading
CALL AIO_BLNK( OCH, STATUS )
CALL AIO_IWRITE( OCH, 2, 'Dataset Selection Information :',
: STATUS )
CALL AIO_BLNK( OCH, STATUS )
* Get number of selection records
CALL SLN_NREC( IFID, NREC, STATUS )
* Display selections
IF ( NREC .EQ. 0 ) THEN
CALL AIO_IWRITE( OCH, 4, '** No selection data in input **',
: STATUS )
CALL AIO_BLNK( OCH, STATUS )
ELSE
* Write each selection
DO I = 1, NREC
* Announce this one
CALL MSG_SETI( 'N', I )
CALL AIO_IWRITE( OCH, 4, 'Selection Record ^N', STATUS )
CALL AIO_BLNK( OCH, STATUS )
* Get this record
CALL SLN_GETREC( IFID, '*', I, SELID, STATUS )
* Get program id
CALL ADI_CGET0C( SELID, 'Version', CREATOR, STATUS )
CALL ASHOW_VAL( CREATOR, 'Creator', ' ', OCH, STATUS )
* Locate Selectors
CALL ADI_FIND( SELID, 'Selectors', SID, STATUS )
* Get number of components
CALL ADI_NCMP( SID, NCMP, STATUS )
DO ICMP = 1, NCMP
* Index the selector
CALL ADI_INDCMP( SID, ICMP, SIID, STATUS )
* Get name and variant
CALL ADI_NAME( SIID, SNAME, STATUS )
CALL ADI_CGET0C( SIID, 'Variant', VARIANT, STATUS )
* Switch on variant
CALL ASHOW_VAL( 'Variant = '//VARIANT, SNAME, ' ',
: OCH, STATUS )
IF ( VARIANT .EQ. 'AREA_DESCRIPTION' ) THEN
CALL ADI_CGET0I( SIID, 'GRPID', GRPID, STATUS )
CALL GRP_GRPSZ(GRPID,SIZE,STATUS)
DO ITXT = 1, SIZE
CALL GRP_GET( GRPID, ITXT, 1, ARDIN, STATUS )
L = CHR_LEN(ARDIN)
IF ( ITXT .EQ. 1 ) THEN
CALL ASHOW_VAL( ARDIN(:L), 'Description', ' ',
: OCH, STATUS )
ELSE
CALL AIO_IWRITE( OCH, 29, ARDIN(:L), STATUS )
END IF
END DO
ELSE IF ( VARIANT .EQ. 'RANGE_PAIRS' ) THEN
* How many pairs?
CALL ADI_CSIZE( SIID, 'START', SIZE, STATUS )
* Map the data
CALL ADI_CMAPR( SIID, 'START', 'READ', BPTR, STATUS )
CALL ADI_CMAPR( SIID, 'STOP', 'READ', EPTR, STATUS )
* Loop over pairs
DO ITXT = 1, SIZE
* Get these values
CALL ARR_ELEM1R( BPTR, SIZE, ITXT, START, STATUS )
CALL ARR_ELEM1R( EPTR, SIZE, ITXT, STOP, STATUS )
* Print 'em out
CALL MSG_SETR( 'START', START )
CALL MSG_SETR( 'STOP', STOP )
CALL MSG_MAKE( '^START -> ^STOP', ARDIN, L )
IF ( ITXT .EQ. 1 ) THEN
CALL ASHOW_VAL( ARDIN(:L), 'Description', ' ',
: OCH, STATUS )
ELSE
CALL AIO_IWRITE( OCH, 29, ARDIN(:L), STATUS )
END IF
END DO
* Release range pairs data
CALL ADI_CUNMAP( SIID, 'START', BPTR, STATUS )
CALL ADI_CUNMAP( SIID, 'STOP', EPTR, STATUS )
END IF
* Release selector
CALL ADI_ERASE( SIID, STATUS )
END DO
* Destroy it
CALL ADI_ERASE( SID, STATUS )
CALL ADI_ERASE( SELID, STATUS )
END DO
END IF
* Report any errors
IF ( STATUS .NE. SAI__OK ) CALL AST_REXIT( 'ASHOW_SEL', STATUS )
END
SUBROUTINE ASHOW_OB( OBJ, MEMBER, TYPE, DESCRIP, UNITS, IMODE,
: OCH, STATUS )
*+
* Name:
* ASHOW_OB
* Purpose:
* Format an ADI item
* Language:
* Starlink Fortran
* Invocation:
* CALL ASHOW_OBI( OBJ, MEMBER, TYPE, DESCRIP, UNITS, IMODE, OCH, STATUS )
* Description:
* {routine_description}
* Arguments:
* OBJ = INTEGER (given)
* ADI object to extract data from
* MEMBER = CHARACTER*(*) (given)
* Name of data member to extract
* TYPE = CHARACTER*(*) (given)
* Type code for item
* DESCRIP = CHARACTER*(*)
* Description of the object
* UNITS = CHARACTER*(*)
* Units of the object
* IMODE = CHARACTER*(*)
* How to handle missing data members
* OCH = INTEGER (given)
* Output channel identifier
* STATUS = INTEGER (given and returned)
* The global status.
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* Keywords:
* ashow, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 (DJA):
* Original version.
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
* Arguments Given:
INTEGER OBJ ! ADI object
CHARACTER*(*) MEMBER, TYPE
CHARACTER*(*) DESCRIP, UNITS
CHARACTER*(*) IMODE
INTEGER OCH ! Output channel
* Status:
INTEGER STATUS ! Global status
* Local Constants:
INTEGER IND ! Indentation
PARAMETER ( IND = 6 )
* Local Variables:
CHARACTER*20 LDESCRIP
CHARACTER*80 CVALUE
DOUBLE PRECISION DVALUE
REAL RVALUE
INTEGER IVALUE
LOGICAL OK ! Data is ok?
LOGICAL THERE ! Member exists?
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Local copy of description
LDESCRIP = DESCRIP
* Does member exist?
CALL ADI_THERE( OBJ, MEMBER, THERE, STATUS )
OK = .FALSE.
IF ( THERE ) THEN
* Extract data
IF ( TYPE .EQ. 'C' ) THEN
CALL ADI_CGET0C( OBJ, MEMBER, CVALUE, STATUS )
ELSE IF ( TYPE .EQ. 'D' ) THEN
CALL ADI_CGET0D( OBJ, MEMBER, DVALUE, STATUS )
ELSE IF ( TYPE .EQ. 'R' ) THEN
CALL ADI_CGET0R( OBJ, MEMBER, RVALUE, STATUS )
ELSE IF ( TYPE .EQ. 'I' ) THEN
CALL ADI_CGET0I( OBJ, MEMBER, IVALUE, STATUS )
END IF
* Trap errors
IF ( STATUS .NE. SAI__OK ) THEN
CALL ERR_ANNUL( STATUS )
ELSE
OK = .TRUE.
END IF
END IF
IF ( OK ) THEN
* Set tokens
IF ( TYPE .EQ. 'C' ) THEN
CALL MSG_SETC( 'VAL', CVALUE )
ELSE IF ( TYPE .EQ. 'R' ) THEN
CALL MSG_SETR( 'VAL', RVALUE )
ELSE IF ( TYPE .EQ. 'D' ) THEN
CALL MSG_SETD( 'VAL', DVALUE )
ELSE IF ( TYPE .EQ. 'I' ) THEN
CALL MSG_SETI( 'VAL', IVALUE )
END IF
CALL MSG_SETC( 'UNITS', UNITS )
CALL AIO_IWRITE( OCH, IND, LDESCRIP//' : ^VAL ^UNITS', STATUS )
ELSE IF ( IMODE .EQ. 'np' ) THEN
IF ( THERE ) THEN
CALL AIO_IWRITE( OCH, IND, LDESCRIP//' : * unreadable *',
: STATUS )
ELSE
CALL AIO_IWRITE( OCH, IND, LDESCRIP//' : * not present *',
: STATUS )
END IF
END IF
END
SUBROUTINE ASHOW_VAL( CVALUE, DESCRIP, UNITS, OCH, STATUS )
*+
* Name:
* ASHOW_VAL
* Purpose:
* Format an ADI item
* Language:
* Starlink Fortran
* Invocation:
* CALL ASHOW_OBI( CVALUE, DESCRIP, UNITS, OCH, STATUS )
* Description:
* {routine_description}
* Arguments:
* CVALUE = CHARACTER*(*) (given)
* Value to format
* DESCRIP = CHARACTER*(*)
* Description of the object
* UNITS = CHARACTER*(*)
* Units of the object
* OCH = INTEGER (given)
* Output channel identifier
* STATUS = INTEGER (given and returned)
* The global status.
* Examples:
* {routine_example_text}
* {routine_example_description}
* Pitfalls:
* {pitfall_description}...
* Notes:
* {routine_notes}...
* Prior Requirements:
* {routine_prior_requirements}...
* Side Effects:
* {routine_side_effects}...
* Algorithm:
* {algorithm_description}...
* Accuracy:
* {routine_accuracy}
* Timing:
* {routine_timing}
* External Routines Used:
* {name_of_facility_or_package}:
* {routine_used}...
* Implementation Deficiencies:
* {routine_deficiencies}...
* Keywords:
* ashow, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 13 Apr 1995 (DJA):
* Original version.
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
* Type Definitions:
IMPLICIT NONE ! No implicit typing
* Global Constants:
INCLUDE 'SAE_PAR' ! Standard SAE constants
* Arguments Given:
CHARACTER*(*) CVALUE, DESCRIP, UNITS
INTEGER OCH ! Output channel
* Status:
INTEGER STATUS ! Global status
* Local Constants:
INTEGER IND ! Indentation
PARAMETER ( IND = 6 )
* Local Variables:
CHARACTER*20 LDESCRIP
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Local copy of description
LDESCRIP = DESCRIP
* Set tokens
CALL MSG_SETC( 'VAL', CVALUE )
CALL MSG_SETC( 'UNITS', UNITS )
CALL AIO_IWRITE( OCH, IND, LDESCRIP//' : ^VAL ^UNITS', STATUS )
END