next up previous
Next: CLASSIFIED LIST OF FORTRAN ROUTINES
Up: EXAMPLE APPLICATIONS
Previous: ADD Add Two NDF Data Structures

NDFTRACE -- Trace an NDF Structure   

The following rather long example is an application to display the attributes of an NDF data structure. It is probably not typical of the use to which the NDF_ routines will be put, but it demonstrates the use of most of the enquiry routines and provides a ``guided tour'' of the NDF components.

      SUBROUTINE NDFTRACE( STATUS )
*+
*  Name:
*     NDFTRACE

*  Purpose:
*     Display the attributes of an NDF data structure.

*  Description:
*     This routine displays the attributes of an NDF data structure
*     including its name, the values of its character components, its
*     shape and the attributes of its data array and of any other array
*     components present. A list of any extensions present, together
*     with their HDS data types, is also included.

*  ADAM Parameters:
*     NDF = NDF (Read)
*        The NDF data structure whose attributes are to be displayed.

*-
      
*  Type Definitions:
      IMPLICIT NONE              ! No implicit typing

*  Global Constants:
      INCLUDE 'SAE_PAR'          ! Standard SAE constants
      INCLUDE 'DAT_PAR'          ! DAT_ public constants
      INCLUDE 'NDF_PAR'          ! NDF_ public constants
      INCLUDE 'PRM_PAR'          ! PRIMDAT primitive data constants

*  Status:
      INTEGER STATUS             ! Global status

*  Local Variables:
      BYTE BADBIT                ! Bad-bits mask
      CHARACTER * ( 35 ) APPN    ! Last recorded application name
      CHARACTER * ( 8 ) BINSTR   ! Binary bad-bits mask string
      CHARACTER * ( DAT__SZLOC ) XLOC ! Extension locator
      CHARACTER * ( DAT__SZTYP ) TYPE ! Extension type
      CHARACTER * ( NDF__MXDIM * ( 2 * VAL__SZI + 3 ) - 2 ) BUF
                                 ! Text buffer for shape information
      CHARACTER * ( NDF__SZFRM ) FORM ! Storage form
      CHARACTER * ( NDF__SZFTP ) FTYPE ! Full data type
      CHARACTER * ( NDF__SZHDT ) CREAT ! History component creation date
      CHARACTER * ( NDF__SZHDT ) DATE ! Date of last history update
      CHARACTER * ( NDF__SZHUM ) HMODE ! History update mode
      CHARACTER * ( NDF__SZXNM ) XNAME ! Extension name
      INTEGER BBI                ! Bad-bits value as an integer
      INTEGER DIGVAL             ! Binary digit value
      INTEGER DIM( NDF__MXDIM )  ! Dimension sizes
      INTEGER I                  ! Loop counter for dimensions
      INTEGER IAXIS              ! Loop counter for axes
      INTEGER IDIG               ! Loop counter for binary digits
      INTEGER INDF               ! NDF identifier
      INTEGER LBND( NDF__MXDIM ) ! Lower pixel-index bounds
      INTEGER N                  ! Loop counter for extensions
      INTEGER NC                 ! Character count
      INTEGER NDIM               ! Number of dimensions
      INTEGER NEXTN              ! Number of extensions
      INTEGER NREC               ! Number of history records
      INTEGER SIZE               ! Total number of pixels
      INTEGER UBND( NDF__MXDIM ) ! Upper pixel-index bounds
      LOGICAL BAD                ! Bad pixel flag
      LOGICAL THERE              ! Whether NDF component is defined

*  Internal References:
      INCLUDE 'NUM_DEC_CVT'      ! NUM_ type conversion routines
      INCLUDE 'NUM_DEF_CVT'

*.

*  Check inherited global status.
      IF ( STATUS .NE. SAI__OK ) RETURN

*  Obtain an identifier for the NDF structure to be examined.
      CALL NDF_ASSOC( 'NDF', 'READ', INDF, STATUS )

*  Display the NDF's name.
      CALL MSG_BLANK( STATUS )
      CALL NDF_MSG( 'NDF', INDF )
      CALL MSG_OUT( 'HEADER', '   NDF structure ^NDF:', STATUS )

*  Character components:
*  ====================
*  See if the title component is defined. If so, then display its
*  value.
      CALL NDF_STATE( INDF, 'Title', THERE, STATUS )
      IF ( THERE ) THEN
         CALL NDF_CMSG( 'TITLE', INDF, 'Title', STATUS )
         CALL MSG_OUT( 'TITLE', '      Title:  ^TITLE', STATUS )
      END IF

*  See if the label component is defined. If so, then display its
*  value.
      CALL NDF_STATE( INDF, 'Label', THERE, STATUS )
      IF ( THERE ) THEN
         CALL NDF_CMSG( 'LABEL', INDF, 'Label', STATUS )
         CALL MSG_OUT( 'LABEL', '      Label:  ^LABEL', STATUS )
      END IF

*  See if the units component is defined. If so, then display its
*  value.
      CALL NDF_STATE( INDF, 'Units', THERE, STATUS )
      IF ( THERE ) THEN
         CALL NDF_CMSG( 'UNITS', INDF, 'Units', STATUS )
         CALL MSG_OUT( 'UNITS', '      Units:  ^UNITS', STATUS )
      END IF

*  NDF shape:
*  =========
*  Obtain the dimension sizes.
      CALL NDF_DIM( INDF, NDF__MXDIM, DIM, NDIM, STATUS )

*  Display a header for this information.
      CALL MSG_BLANK( STATUS )
      CALL MSG_OUT( 'SHAPE_HEADER', '   Shape:', STATUS )

*  Display the number of dimensions.
      CALL MSG_SETI( 'NDIM', NDIM )
      CALL MSG_OUT( 'DIMENSIONALITY',
     : '      No. of dimensions:  ^NDIM', STATUS )

*  Construct a string showing the dimension sizes.
      NC = 0
      DO 1 I = 1, NDIM
          IF ( I .GT. 1 ) CALL CHR_PUTC( ' x ', BUF, NC )
          CALL CHR_PUTI( DIM( I ), BUF, NC )
 1    CONTINUE
      CALL MSG_SETC( 'DIMS', BUF( : NC ) )

*  Display the dimension size information.
      CALL MSG_OUT( 'DIMENSIONS',
     : '      Dimension size(s):  ^DIMS', STATUS )

*  Obtain the pixel-index bounds.
      CALL NDF_BOUND( INDF, NDF__MXDIM, LBND, UBND, NDIM, STATUS )

*  Construct a string showing the pixel-index bounds.
      NC = 0
       DO 2 I = 1, NDIM
         IF ( I .GT. 1 ) CALL CHR_PUTC( ', ', BUF, NC )
         CALL CHR_PUTI( LBND( I ), BUF, NC )
         CALL CHR_PUTC( ':', BUF, NC )
         CALL CHR_PUTI( UBND( I ), BUF, NC )
 2    CONTINUE
      CALL MSG_SETC( 'BNDS', BUF( : NC ) )

*  Display the pixel-index bounds information.
      CALL MSG_OUT( 'BOUNDS',
     : '      Pixel bounds     :  ^BNDS', STATUS )

*  Obtain the NDF size and display this information.
      CALL NDF_SIZE( INDF, SIZE, STATUS )
      CALL MSG_SETI( 'SIZE', SIZE )
      CALL MSG_OUT( 'SIZE',
     : '      Total pixels     :  ^SIZE ', STATUS )

*  Axis component:
*  ==============
*  See if the axis coordinate system is defined. If so then output a header
*  for it.
      CALL NDF_STATE( INDF, 'Axis', THERE, STATUS )
      IF ( THERE ) THEN
         CALL MSG_BLANK( STATUS )
         CALL MSG_OUT( 'AXIS_HEADER', '   Axes:', STATUS )

*  Loop to obtain the label and units for each axis and display them.
         DO 3 IAXIS = 1, NDIM
            CALL MSG_SETI( 'IAXIS', IAXIS )
            CALL NDF_ACMSG( 'LABEL', INDF, 'Label', IAXIS, STATUS )
            CALL NDF_ACMSG( 'UNITS', INDF, 'Units', IAXIS, STATUS )
            CALL MSG_OUT( 'AXIS_LABEL',
     :      '      ^IAXIS: ^LABEL (^UNITS)', STATUS )
 3       CONTINUE
      END IF

*  Data component:
*  ==============
*  Obtain the data component attributes.
      CALL NDF_FTYPE( INDF, 'Data', FTYPE, STATUS )
      CALL NDF_FORM( INDF, 'Data', FORM, STATUS )

*  Display the data component attributes.
      CALL MSG_BLANK( STATUS )
      CALL MSG_OUT( 'DATA_HEADER', '   Data Component:', STATUS )
      CALL MSG_SETC( 'FTYPE', FTYPE )
      CALL MSG_OUT( 'DATA_TYPE', '      Type        :  ^FTYPE', STATUS )
      CALL MSG_SETC( 'FORM', FORM )
      CALL MSG_OUT( 'DATA_FORM', '      Storage form:  ^FORM', STATUS )

*  Determine if the data values are defined. Issue a warning message if
*  they are not.
      CALL NDF_STATE( INDF, 'Data', THERE, STATUS )
      IF ( .NOT. THERE ) THEN
         CALL MSG_OUT( 'DATA_UNDEF',
     :   '      WARNING: the Data component values are not defined',
     :                 STATUS )

*  Disable automatic quality masking and see if the data component may
*  contain bad pixels. If so, then display an appropriate message.
      ELSE
         CALL NDF_SQMF( .FALSE., INDF, STATUS )
         CALL NDF_BAD( INDF, 'Data', .FALSE., BAD, STATUS )
         IF ( BAD ) THEN
            CALL MSG_OUT( 'DATA_ISBAD',
     :      '      Bad pixels may be present', STATUS )

*  If there were no bad pixels present, then re-enable quality masking
*  and test again. Issue an appropriate message.
         ELSE
            CALL NDF_SQMF( .TRUE., INDF, STATUS )
            CALL NDF_BAD( INDF, 'Data', .FALSE., BAD, STATUS )
            IF ( .NOT. BAD ) THEN
               CALL MSG_OUT( 'DATA_NOBAD',
     :         '      There are no bad pixels present', STATUS )
            ELSE
               CALL MSG_OUT( 'DATA_QBAD',
     :         '      Bad pixels may be introduced via the Quality ' //
     :         'component', STATUS )
            END IF
         END IF
      END IF

*  Variance component:
*  ==================
*  See if the variance component is defined.  If so, then obtain its
*  attributes.
      CALL NDF_STATE( INDF, 'Variance', THERE, STATUS )
      IF ( THERE ) THEN
         CALL NDF_FTYPE( INDF, 'Variance', FTYPE, STATUS )
         CALL NDF_FORM( INDF, 'Variance', FORM, STATUS )

*  Display the variance component attributes.
         CALL MSG_BLANK( STATUS )
         CALL MSG_OUT( 'VAR_HEADER', '   Variance Component:', STATUS )
         CALL MSG_SETC( 'FTYPE', FTYPE )
         CALL MSG_OUT( 'VAR_TYPE', '      Type        :  ^FTYPE',
     :                 STATUS )
         CALL MSG_SETC( 'FORM', FORM )
         CALL MSG_OUT( 'VAR_FORM', '      Storage form:  ^FORM',
     :                 STATUS )

*  Disable automatic quality masking and see if the variance component
*  may contain bad pixels. If so, then display an appropriate message.
         CALL NDF_SQMF( .FALSE., INDF, STATUS )
         CALL NDF_BAD( INDF, 'Variance', .FALSE., BAD, STATUS )
         IF ( BAD ) THEN
            CALL MSG_OUT( 'VAR_ISBAD',
     :      '      Bad pixels may be present', STATUS )

*  If there were no bad pixels present, then re-enable quality masking
*  and test again. Issue an appropriate message.
         ELSE
            CALL NDF_SQMF( .TRUE., INDF, STATUS )
            CALL NDF_BAD( INDF, 'Variance', .FALSE., BAD, STATUS )
            IF ( .NOT. BAD ) THEN
               CALL MSG_OUT( 'VAR_NOBAD',
     :         '      There are no bad pixels present', STATUS )
            ELSE
               CALL MSG_OUT( 'VAR_QBAD',
     :         '      Bad pixels may be introduced via the Quality ' //
     :         'component', STATUS )
            END IF
         END IF
      END IF

*  Quality component:
*  =================
*  See if the quality component is defined. If so, then obtain its
*  attributes.
      CALL NDF_STATE( INDF, 'Quality', THERE, STATUS )
      IF ( THERE ) THEN
         CALL NDF_FORM( INDF, 'Quality', FORM, STATUS )

*  Display the quality component attributes.
         CALL MSG_BLANK( STATUS )
         CALL MSG_OUT( 'QUALITY_HEADER', '   Quality Component:',
     :                 STATUS )
         CALL MSG_SETC( 'FORM', FORM )
         CALL MSG_OUT( 'QUALITY_FORM', '      Storage form :  ^FORM',
     :                  STATUS )

*  Obtain the bad-bits mask value.
         CALL NDF_BB( INDF, BADBIT, STATUS )

*  Generate a binary representation in a character string.
         BBI = NUM_UBTOI( BADBIT )
         DIGVAL = 2 ** 7
         DO 4 IDIG = 1, 8
            IF ( BBI .GE. DIGVAL ) THEN
               BINSTR( IDIG : IDIG ) = '1'
               BBI = BBI - DIGVAL
            ELSE
               BINSTR( IDIG : IDIG ) = '0'
            END IF
            DIGVAL = DIGVAL / 2
 4       CONTINUE

*  Display the bad-bits mask information.
         CALL MSG_SETI( 'BADBIT', NUM_UBTOI( BADBIT ) )
         CALL MSG_SETC( 'BINARY', BINSTR )
         CALL MSG_OUT( 'QUALITY_BADBIT',
     :   '      Bad-bits mask:  ^BADBIT (binary ^BINARY)', STATUS )
      END IF

*  Extensions:
*  ==========
*  Determine how many extensions are present.
      CALL NDF_XNUMB( INDF, NEXTN, STATUS )

*  Display a heading for the extensions.
      IF ( NEXTN .GT. 0 ) THEN
         CALL MSG_BLANK( STATUS )
         CALL MSG_OUT( 'EXTN_HEADER', '   Extensions:', STATUS )

*  Loop to obtain the name and HDS data type of each extension.
         DO 5 N = 1, NEXTN
            CALL NDF_XNAME( INDF, N, XNAME, STATUS )
            CALL NDF_XLOC( INDF, XNAME, 'READ', XLOC, STATUS )
            CALL DAT_TYPE( XLOC, TYPE, STATUS )
            CALL DAT_ANNUL( XLOC, STATUS )

*  Display the information for each extension.
            CALL MSG_SETC( 'TYPE', TYPE )
            CALL MSG_OUT( 'EXTN',
     :      '      ' // XNAME // '  <^TYPE>', STATUS )
 5       CONTINUE
      END IF

*  History:
*  =======
*  See if a history component is present.
      CALL NDF_STATE( INDF, 'History', THERE, STATUS )

*  If so, then obtain its attributes.
      IF ( THERE ) THEN
         CALL NDF_HINFO( INDF, 'CREATED', 0, CREAT, STATUS )
         CALL NDF_HNREC( INDF, NREC, STATUS )
         CALL NDF_HINFO( INDF, 'MODE', 0,  HMODE, STATUS )
         CALL NDF_HINFO( INDF, 'DATE', NREC, DATE, STATUS )
         CALL NDF_HINFO( INDF, 'APPLICATION', NREC, APPN, STATUS )

*  Display the history component attributes.
         CALL MSG_BLANK( STATUS )
         CALL MSG_OUT( 'HISTORY_HEADER', '   History Component:',
     :                 STATUS )
         CALL MSG_SETC( 'CREAT', CREAT( : 20 ) )
         CALL MSG_OUT( 'HISTORY_CREAT',
     :                 '      Created    :  ^CREAT', STATUS )
         CALL MSG_SETI( 'NREC', NREC )
         CALL MSG_OUT( 'HISTORY_NREC',
     :                 '      No. records:  ^NREC', STATUS )
         CALL MSG_SETC( 'DATE', DATE( : 20 ) )
         CALL MSG_SETC( 'APPN', APPN )
         CALL MSG_OUT( 'HISTORY_DATE',
     :                 '      Last update:  ^DATE (^APPN)', STATUS )
         CALL MSG_SETC( 'HMODE', HMODE )
         CALL MSG_OUT( 'HISTORY_HMODE',
     :                 '      Update mode:  ^HMODE', STATUS )
      END IF
      CALL MSG_BLANK( STATUS )

*  Clean up:
*  ========
*  Annul the NDF identifier.
      CALL NDF_ANNUL( INDF, STATUS )

*  If an error occurred, then report context information.
      IF ( STATUS .NE. SAI__OK ) THEN
         CALL ERR_REP( 'NDFTRACE_ERR',
     :   'NDFTRACE: Error displaying the attributes of an NDF ' //
     :   'data structure.', STATUS )
      END IF

      END

The following is an example ADAM interface file (ndftrace.ifl) for the application above.

   interface NDFTRACE

      parameter NDF                 # NDF to be inspected
         position 1
         prompt   'Data structure'
      endparameter

   endinterface



next up previous
Next: CLASSIFIED LIST OF FORTRAN ROUTINES
Up: EXAMPLE APPLICATIONS
Previous: ADD Add Two NDF Data Structures


Starlink User Note 33
R.F. Warren-Smith
11th January 2000
E-mail:rfws@star.rl.ac.uk

Copyright © 2000 Council for the Central Laboratory of the Research Councils