The following FORTRAN listing is the output routine from the SuperCOSMOS LANESORT program. It uses the include file IAMREC_PAR which contains suitable mnemonic constants for the indices into the input array corresponding to the various IAM parameters.
*+ LANESORT_COPY - copy records between IAM files subject to deblending
SUBROUTINE LANESORT_COPY ( INPUT, OUTPUT, SELECT, NUMOBJ, ID,
: STATUS )
* Description :
* Copy the record numbers held in ID from the input file to the
* output file. If the SELECT criterion is PARENT+CHILD, append child
* objects immediately after the corresponding parent.
* Invocation :
* CALL LANESORT_COPY ( INPUT, OUTPUT, SELECT, NUMOBJ, ID,
* : STATUS )
* Parameters :
* INPUT=INTEGER (given)
* RECIO unit number for input data set
* OUTPUT=INTEGER (given)
* RECIO unit number for output data set
* SELECT=CHARACTER*(*) (given)
* debled selection criterion - PARENT, CHILD or PARENT+CHILD
* NUMOBJ=INTEGER (given)
* number of objects in sorted list
* ID(NUMOBJ)=INTEGER (given)
* sorted list of record numbers in input file
* STATUS=INTEGER (given and returned)
* global status
* Method :
* The basic procedure is to read records from INPUT as given by ID,
* and append them to OUTPUT to give a sorted copy of the IAM dataset.
* However, if SELECT is 'PARENT+CHILD', then the deblend parameter is
* checked for each object from INPUT, and if it is a PARENT, it is
* copied to OUTPUT immediately followed by its child objects.
* Random acess to the input file is achieved by using RECIO_POSITION.
* This is much more expensive in time than just sequential reads, so
* an attempt is made to avoid POSITION calls if they are unnecessary.
* Authors :
* B.D.Kelly (ROE)
* History :
* 10 May 1995: original (BDK)
* endhistory
* Type Definitions :
IMPLICIT NONE
* Global constants :
INCLUDE 'SAE_PAR'
INCLUDE 'IAMREC_PAR'
* Import :
INTEGER INPUT ! RECIO unit number for input data set
INTEGER OUTPUT ! RECIO unit number for output data set
CHARACTER*(*) SELECT ! debled selection criterion -
! PARENT, CHILD or PARENT+CHILD
INTEGER NUMOBJ ! number of objects in sorted list
INTEGER ID(NUMOBJ) ! sorted list of record numbers in input file
* Status :
INTEGER STATUS ! global status
* Local variables :
INTEGER ENDFILE ! end-of-file flag
CHARACTER*132 ERRMSG ! error message from RECIO
INTEGER I ! loop counter
INTEGER INREC(IAMREC__NUMPARS) ! input buffer
INTEGER J ! loop counter
CHARACTER*32 LOCSEL ! uppercase copy of SELECT
INTEGER NUMCHILD ! number of children deblended from
! a parent
INTEGER OLDREC ! last input record read
INTEGER RECLEN ! record length in bytes
*-
IF ( STATUS .NE. SAI__OK ) RETURN
LOCSEL = SELECT
CALL CHR_UCASE ( LOCSEL )
RECLEN = IAMREC__NUMPARS * 4
IF ( ( INDEX ( LOCSEL, 'PARENT' ) .EQ. 0 ) .OR.
: ( INDEX ( LOCSEL, 'CHILD' ) .EQ. 0 ) ) THEN
*
* Simply copy records
*
OLDREC = 0
DO J = 1, NUMOBJ
IF ( OLDREC .NE. ( ID(J) - 1 ) ) THEN
CALL RECIO_POSITION ( INPUT, RECLEN, ID(J), STATUS )
ENDIF
CALL RECIO_READ ( INPUT, RECLEN, INREC, ENDFILE, STATUS )
IF ( ENDFILE .EQ. 0 ) THEN
CALL RECIO_WRITE ( OUTPUT, RECLEN, INREC, STATUS )
ELSE
STATUS = SAI__ERROR
ENDIF
OLDREC = ID(J)
ENDDO
ELSE
*
* Copy records taking account of parent-child relationships
*
OLDREC = 0
DO J = 1, NUMOBJ
IF ( OLDREC .NE. ( ID(J) - 1 ) ) THEN
CALL RECIO_POSITION ( INPUT, RECLEN, ID(J), STATUS )
ENDIF
CALL RECIO_READ ( INPUT, RECLEN, INREC, ENDFILE, STATUS )
IF ( ENDFILE .EQ. 0 ) THEN
CALL RECIO_WRITE ( OUTPUT, RECLEN, INREC, STATUS )
OLDREC = ID(J)
NUMCHILD = -INREC(IAMREC__BLEND)
IF ( NUMCHILD .GT. 0 ) THEN
DO I = 1, NUMCHILD
CALL RECIO_READ ( INPUT, RECLEN, INREC, ENDFILE,
: STATUS )
IF ( ENDFILE .EQ. 0 ) THEN
CALL RECIO_WRITE ( OUTPUT, RECLEN, INREC,
: STATUS )
ELSE
STATUS = SAI__ERROR
ENDIF
ENDDO
OLDREC = ID(J) + NUMCHILD
ENDIF
ELSE
STATUS = SAI__ERROR
ENDIF
ENDDO
ENDIF
IF ( STATUS .NE. SAI__OK ) THEN
*
* On unexpected endfile, this routine will have set SAI__ERROR.
* Any other status will have been set by RECIO, and so needs
* translating.
*
IF ( STATUS .EQ. SAI__ERROR ) THEN
CALL ERR_REP ( ' ',
: 'LANESORT_COPY: unexpected end of file on IAM input',
: STATUS )
ELSE
CALL RECIO_ERRTRAN ( ERRMSG, STATUS )
CALL ERR_REP ( ' ', ERRMSG, STATUS )
ENDIF
ENDIF
END