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