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