SUBROUTINE AST2QDP( STATUS )
*+
* Name:
* AST2QDP
* Purpose:
* Converts a 1D binned dataset to QDP format
* Language:
* Starlink Fortran
* Type of Module:
* ASTERIX task
* Invocation:
* CALL AST2QDP( STATUS )
* Arguments:
* STATUS = INTEGER (Given and Returned)
* The global status.
* Description:
* {routine_description}
* Usage:
* ast2qdp {parameter_usage}
* Environment Parameters:
* INP = CHAR (read)
* The input binned dataset
* OUT = CHAR (read)
* Output text file name
* 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:
* ast2qdp, usage:public
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 8 Apr 1991 V1.4-0 (DJA):
* Original version.
* 14 Oct 1992 V1.4-1 (DJA):
* NCMD explicity zeroed
* 22 Sep 1993 V1.7-0 (DJA):
* Treatment of axis widths corrected (DJA)
* 8 Nov 1994 V1.8-0 (DJA):
* Updated to use new graphics
* 24 Nov 1994 V1.8-1 (DJA):
* Now use USI for user interface (DJA)
* 22 Feb 1995 V1.8-2 (DJA):
* Write to file rather than invoking PLT directly.
* Use BDI for data interface, and AIO for output.
* 1 Aug 1995 V1.8-3 (DJA):
* New prologues.
* 14 Dec 1995 V2.0-0 (DJA):
* ADI port
* {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 'PRM_PAR'
* Status:
INTEGER STATUS ! Global status
* Local Constants:
CHARACTER*30 VERSION
PARAMETER ( VERSION = 'AST2QDP Version V2.0-0' )
* Local Variables:
CHARACTER*80 LABEL !
CHARACTER*80 TITLE !
CHARACTER*40 UNITS !
REAL LO, HI ! Range bounds
REAL SIZE ! Character size
INTEGER APTR, AWPTR ! Axis data/width
INTEGER DPTR ! Data values
INTEGER EPTR ! Error values
INTEGER IFID ! Input dataset
INTEGER NDIM ! Dimensionality
INTEGER NELM ! # of data items
INTEGER OID ! Output text file
INTEGER QPTR ! Quality pointer
INTEGER STYLE ! Line style
INTEGER SYM ! Symbol type
INTEGER WIDTH ! Width of output file
LOGICAL AOK ! Axis data valid?
LOGICAL AWOK ! Axis widths valid?
LOGICAL DOK ! Data valid?
LOGICAL LSET, HSET ! Range bounds set?
LOGICAL OK ! General validity?
LOGICAL QOK ! Quality ok?
LOGICAL VOK ! Variance ok?
LOGICAL PRIM ! Input primitive?
LOGICAL SET,SIZ_SET ! Size set?
LOGICAL STY_SET ! Style set?
LOGICAL SYM_SET ! Symbol set?
LOGICAL XLOG, YLOG ! Log axes?
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Version id
CALL MSG_PRNT( VERSION )
* Initialise ASTERIX
CALL AST_INIT()
* Associate input file
CALL USI_ASSOC( 'INP', 'BinDS|Array', 'READ', IFID, STATUS )
CALL ADI_DERVD( IFID, 'Array', PRIM, STATUS )
IF ( STATUS .NE. SAI__OK ) GOTO 99
* Get output text file
CALL AIO_ASSOCO( 'OUT', 'LIST', OID, WIDTH, STATUS )
* Check data
CALL BDI_CHK( IFID, 'Data', DOK, STATUS )
CALL BDI_GETSHP( IFID, 1, NELM, NDIM, STATUS )
IF ( .NOT. DOK ) THEN
STATUS = SAI__ERROR
CALL ERR_REP( ' ', 'Invalid data', STATUS )
GOTO 99
END IF
* Warning if primitive
IF ( PRIM ) THEN
CALL MSG_PRNT( 'Primitive input - pixel numbers will be'/
: /' used for axis' )
END IF
* Quality and variance present?
CALL BDI_CHK( IFID, 'Quality', QOK, STATUS )
CALL BDI_CHK( IFID, 'Variance', VOK, STATUS )
* Check axis data and widths
IF ( .NOT. PRIM ) THEN
CALL BDI_AXCHK( IFID, 1, 'Data', AOK, STATUS )
CALL BDI_AXCHK( IFID, 1, 'Width', AWOK, STATUS )
IF ( .NOT. AOK ) THEN
CALL MSG_PRNT( 'No axis values present in input, will use'/
: /' pixel number instead' )
AWOK = .FALSE.
END IF
ELSE
AOK = .FALSE.
AWOK = .FALSE.
END IF
IF ( STATUS .NE. SAI__OK ) GOTO 99
* Axis data
IF ( AOK ) THEN
CALL BDI_AXMAPR( IFID, 1, 'Data', 'READ', APTR, STATUS )
END IF
* Widths
IF ( AWOK ) THEN
CALL BDI_AXMAPR( IFID, 1, 'Width', 'READ', AWPTR, STATUS )
END IF
* Map quality
IF ( QOK ) THEN
CALL BDI_MAPL( IFID, 'LogicalQuality', 'READ', QPTR, STATUS )
END IF
* Copy data array
CALL BDI_MAPR( IFID, 'Data', 'READ', DPTR, STATUS )
IF ( VOK ) CALL BDI_MAPR( IFID, 'Error', 'READ', EPTR, STATUS )
* Write a command telling QDP how to read the errors
IF ( AWOK .AND. VOK ) THEN
CALL AIO_WRITE( OID, 'READ SERR 1 2', STATUS )
ELSE IF ( AWOK ) THEN
CALL AIO_WRITE( OID, 'READ SERR 1', STATUS )
ELSE IF ( VOK ) THEN
CALL AIO_WRITE( OID, 'READ SERR 2', STATUS )
END IF
* Dataset title
CALL BDI_GET0C( IFID, 'Title', TITLE, STATUS )
IF ( TITLE .GT. ' ' ) THEN
CALL MSG_SETC( 'LAB', TITLE )
CALL AIO_WRITE( OID, 'LABEL T "^LAB"', STATUS )
END IF
* X axis label and units
CALL BDI_AXGET0C( IFID, 1, 'Label', LABEL, STATUS )
IF ( LABEL .GT. ' ' ) THEN
CALL BDI_AXGET0C( IFID, 1, 'Units', UNITS, STATUS )
IF ( UNITS .GT. ' ' ) THEN
CALL MSG_SETC( 'UNIT', UNITS )
CALL MSG_SETC( 'LAB', LABEL )
CALL AIO_WRITE( OID, 'LAB X "^LAB (^UNIT)"', STATUS )
ELSE
CALL MSG_SETC( 'LAB', LABEL )
CALL AIO_WRITE( OID, 'LAB X "^LAB"', STATUS )
END IF
END IF
* The data (=Y) axis label and units
CALL BDI_GET0C( IFID, 'Label', LABEL, STATUS )
IF ( LABEL .GT. ' ' ) THEN
CALL MSG_SETC( 'LAB', LABEL )
CALL BDI_GET0C( IFID, 'Units', UNITS, STATUS )
IF ( UNITS .GT. ' ' ) THEN
CALL MSG_SETC( 'UNIT', UNITS )
CALL AIO_WRITE( OID, 'LABEL Y "^LAB (^UNIT)"', STATUS )
ELSE
CALL AIO_WRITE( OID, 'LABEL Y "^LAB"', STATUS )
END IF
END IF
* Connect to graphics system
CALL GCB_LCONNECT( STATUS )
CALL GCB_FLOAD( IFID, STATUS )
* X range?
CALL GCB_GETR( 'XAXIS_LO', LSET, LO, STATUS )
CALL GCB_GETR( 'XAXIS_HI', HSET, HI, STATUS )
IF ( LSET .AND. HSET ) THEN
CALL MSG_SETR( 'LO', LO )
CALL MSG_SETR( 'HI', HI )
CALL AIO_WRITE( OID, 'RESCALE X ^LO ^HI', STATUS )
END IF
* Log X axis?
CALL GCB_GETL( 'XAXIS_LOG', OK, XLOG, STATUS )
IF ( OK .AND. XLOG ) THEN
CALL AIO_WRITE( OID, 'LOG X', STATUS )
END IF
* Y range?
CALL GCB_GETR( 'YAXIS_LO', LSET, LO, STATUS )
CALL GCB_GETR( 'YAXIS_HI', HSET, HI, STATUS )
IF ( LSET .AND. HSET ) THEN
CALL MSG_SETR( 'LO', LO )
CALL MSG_SETR( 'HI', HI )
CALL AIO_WRITE( OID, 'RESCALE Y ^LO ^HI', STATUS )
END IF
* Log Y axis?
CALL GCB_GETL( 'XAXIS_LOG', OK, YLOG, STATUS )
IF ( OK .AND. YLOG ) THEN
CALL AIO_WRITE( OID, 'LOG Y', STATUS )
END IF
* Markers? Only size and symbol available in PLT command
CALL GCB_GETL( 'POINT_FLAG', OK, SET, STATUS )
IF ( OK .AND. SET ) THEN
CALL GCB_GETI( 'POINT_SYMBOL', SYM_SET, SYM, STATUS )
CALL GCB_GETR( 'POINT_SIZE', SIZ_SET, SIZE, STATUS )
IF ( .NOT. SYM_SET ) SYM = 2
IF ( .NOT. SIZ_SET ) SIZE = 1.0
CALL MSG_SETI( 'SYM', SYM )
CALL MSG_SETR( 'SIZ', SIZE )
CALL AIO_WRITE( OID, 'MARK ^SYM ON SIZE ^SIZ', STATUS )
END IF
* Polyline?
CALL GCB_GETL( 'POLY_FLAG', OK, SET, STATUS )
IF ( OK .AND. SET ) THEN
CALL GCB_GETI( 'POLY_STYLE', STY_SET, STYLE, STATUS )
IF ( STY_SET ) THEN
CALL MSG_SETI( 'STY', STYLE )
CALL AIO_WRITE( OID, 'LSTYLE ^STY ON', STATUS )
END IF
CALL AIO_WRITE( OID, 'LINE ON', STATUS )
END IF
* Stepline?
CALL GCB_GETL( 'STEP_FLAG', OK, SET, STATUS )
IF ( OK .AND. SET ) THEN
CALL GCB_GETI( 'STEP_STYLE', STY_SET, STYLE, STATUS )
IF ( STY_SET ) THEN
CALL MSG_SETI( 'STY', STYLE )
CALL AIO_WRITE( OID, 'LSTYLE ^STY ON', STATUS )
END IF
CALL AIO_WRITE( OID, 'LINE STEPPED ON', STATUS )
ELSE
CALL AIO_WRITE( OID, 'LINE OFF', STATUS )
END IF
* Detach from graphics
CALL GCB_DETACH( STATUS )
* Write the data
CALL AST2QDP_WDATA( OID, NELM, %VAL(DPTR), QOK, %VAL(QPTR),
: AOK, %VAL(APTR), AWOK, %VAL(AWPTR),
: VOK, %VAL(EPTR), STATUS )
* Close output file
CALL AIO_CANCL( 'OUT', STATUS )
* Tidy up
99 CALL AST_CLOSE( STATUS )
CALL AST_ERR( STATUS )
END
SUBROUTINE AST2QDP_WDATA( OID, N, DATA, QOK, QUAL, AOK, AXIS,
: AWOK, AXWID, EOK, ERRS, STATUS )
*+
* Name:
* AST2QDP_WDATA
* Purpose:
* Write data from arrays to AIO file in QDP format
* Language:
* Starlink Fortran
* Type of Module:
* ASTERIX task
* Invocation:
* CALL AST2QDP_WDATA( OID, N, DATA, QOK, QUAL, AOK, AXIS,
* AWOK, AXWID, EOK, ERRS, STATUS )
* Arguments:
* OID = INTEGER (given)
* Output file identifier
* N = INTEGER (given)
* Number of data values
* DATA[] = REAL (given)
* Data values
* QOK = LOGICAL (given)
* Quality values present?
* QUAL[] = LOGICAL (given)
* Quality values
* AOK = LOGICAL (given)
* Axis values present?
* AXIS[] = REAL (given)
* Axis data values
* AWOK = LOGICAL (given)
* Axis width values present?
* AXWID[] = REAL (given)
* Axis width data values
* EOK = LOGICAL (given)
* Error values present?
* ERRS[] = REAL (given)
* Error values
* STATUS = INTEGER (Given and Returned)
* The global status.
* Description:
* {routine_description}
* 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}...
* Keywords:
* ast2qdp, usage:private
* Copyright:
* Copyright (C) University of Birmingham, 1995
* Authors:
* DJA: David J. Allan (Jet-X, University of Birmingham)
* {enter_new_authors_here}
* History:
* 8 Apr 1991 (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
* Import:
INTEGER OID, N
REAL DATA(*), AXIS(*), AXWID(*), ERRS(*)
LOGICAL QOK, AOK, AWOK, EOK
LOGICAL QUAL(*)
* Status:
INTEGER STATUS ! Global status
* Local Constants:
CHARACTER*10 RFMT
PARAMETER ( RFMT = '(1PG14.6)' )
CHARACTER*10 IFMT
PARAMETER ( IFMT = '(I6)' )
* Local Variables:
CHARACTER*132 BUF ! Output buffer
INTEGER ACOL ! Axis column
INTEGER AWCOL ! Axis width column
INTEGER DCOL ! Data column
INTEGER ECOL ! Errors column
INTEGER FSTAT ! i/o status
INTEGER I ! Loop over data
INTEGER LCOL ! Last column in use
LOGICAL OK ! Point is ok?
*.
* Check inherited global status.
IF ( STATUS .NE. SAI__OK ) RETURN
* Good by default
OK = .TRUE.
* Choose columns for output
ACOL = 1
IF ( AOK ) THEN
IF ( AWOK ) THEN
AWCOL = ACOL + 15
ELSE
AWCOL = ACOL
END IF
DCOL = AWCOL + 15
ELSE
DCOL = ACOL + 6
END IF
IF ( EOK ) THEN
ECOL = DCOL + 15
ELSE
ECOL = DCOL
END IF
LCOL = ECOL + 16
* Loop over data
DO I = 1, N
* Point is good?
IF ( QOK ) OK = QUAL(I)
IF ( OK ) THEN
* Clear buffer
BUF(:LCOL) = ' '
* Write axis value, or pixel if not present
IF ( AOK ) THEN
WRITE( BUF(ACOL:ACOL+13), RFMT, IOSTAT=FSTAT ) AXIS(I)
IF ( AWOK ) THEN
WRITE( BUF(AWCOL:AWCOL+13), RFMT, IOSTAT=FSTAT )
: AXWID(I)*0.5
END IF
ELSE
WRITE( BUF(ACOL:ACOL+5), IFMT, IOSTAT=FSTAT ) I
END IF
* Write the data value
WRITE( BUF(DCOL:DCOL+13), RFMT, IOSTAT=FSTAT ) DATA(I)
* Write error value
IF ( EOK ) THEN
WRITE( BUF(ECOL:ECOL+13), RFMT, IOSTAT=FSTAT ) ERRS(I)
END IF
* Write buffer
CALL AIO_WRITE( OID, BUF(:LCOL), STATUS )
* End of good point test
END IF
* End of loop over data points
END DO
END