*
* $Id: tapeload,v 1.1.1.1 1996/03/07 15:17:35 mclareni Exp $
*
* $Log: tapeload,v $
* Revision 1.1.1.1  1996/03/07 15:17:35  mclareni
* Fatmen
*
*
* This directory was created from fatmen.car patch tapeload
      PROGRAM TAPELOAD
*...TAPELOAD
*.    FATMEN utility program to read tape details from a number of files
*.    ,extracting and processing the relevant information,before storing
*.    it within the FATMEN file catalogue.The 3 types of file that must
*.    be made available to the program are as follows:
*.       1. A file of tape Volume Serial Numbers,identifying each tape
*.          file to be processed - these having already been staged as
*.          seperate disk files of the same name.
*.       2. A number of tape files staged onto disk,each containing the
*.          compulsory header and data components,and optionally a
*.          trailer component.
*.       3. A file containing run information for a number of tapes,this
*.          being inclusive of a generic name,a list of detectors not in
*.          use during the run,various other tape information and
*.          possibly a user comment.
*.    Only the information required for each catalogue entry is
*.    extracted from the above.Where an entry cannot be made the FATMEN
*.    default is allowed to take effect.
*.
*. COMMON     :
*. SEQUENCE   :
*. CALLS      : ERRSET MZEBRA MZSTOR MZLOGL MZLINK FMINIT FMLIFT
*.              FMLINK UCTOH  DBPKTM DZSHOW FMPUT
*.              HDRTRL BINTCM GETTAP CONCAT FATDAT
*. CALLED     :
*.
*. BANKS L    :
*. BANKS U    :
*. BANKS M    :
*. BANKS D    :
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : G.J.Barlow
*. VERSION    :
*. CREATED    : 02-Nov-89
*. LAST MOD   :
*.
*. Modification Log.
*.
*.**********************************************************************
*.
*--- Assign data set mnemonics for bank keys.
*
#include "fatpara.inc"
*
      PARAMETER (LURCOR=200000)
      COMMON /CRZT/ IXSTOR,IXDIV,IFENCE(2),LEV,LEVIN,BLVECT(LURCOR)
      DIMENSION LQ(999),IQ(999),Q(999)
      EQUIVALENCE (IQ(1),Q(1),LQ(9)),(LQ(1),LEV)
*
      COMMON /USRLNK/ LUSRK1,LUSRBK,LUSRLS
      COMMON /QUEST/ IQUEST(100)
      PARAMETER (LKEYFA=10)
      DIMENSION KEYS(LKEYFA)
*
      INTEGER ICTRX,IPTRG,IUNITA,IUNITB,IUNITC,IRC,IOSTAT
      PARAMETER (IUNITA=3,IUNITB=9,IUNITC=8)
      INTEGER NRECS
      INTEGER IOFILE,NBYTES
      PARAMETER (IOFILE = 1)
*
      INTEGER IDATE,ITIME,IPACK
      INTEGER IBLKLN(2),IRECLN(2),ITAPDV(2),ITAPDN(7)
      INTEGER IVLSQN(2),IDSSQN(2),ICRDAT(2),IBLKCT(2)
      INTEGER ICPLVL,ILOCCD,IMEDTP,ISTREC,IENREC,ISTBLK
      INTEGER IFLSIZ,IDUMMY
*
      CHARACTER*80 CBUFF
      CHARACTER*54 CGNAME
      CHARACTER*7 CBDISP
      CHARACTER*17 CDATID(2)
      CHARACTER*4 CFATFM,CLABEL,CDSSQN,CLABRQ(2,2)
      CHARACTER*6 CINVSN,CVLSLN,CVISID
      CHARACTER*1 CRECFT(2)
      CHARACTER*80 CDETOT,CCOM1,CCOM2,COMMNT
*
      LOGICAL BERROR,BDIFF
      LOGICAL BINTCM
      DATA    NSHOWN/0/
*
*--- Declare common blocks,containing the arrays responsible for storing
*--- the Header and Trailer fields from the staged TAPE files.
*
      COMMON /TAPDL1/ CDATID,CRECFT
      COMMON /TAPDL2/ IBLKLN,IRECLN,ITAPDV,IVLSQN,IDSSQN,ICRDAT,IBLKCT
*
*--- Assign defaults to the file catalogue fields,for which values are
*--- not supplied in either the Tape file or the Run Information file.
*--- Additionally,set values within a number of arrays,to be used for
*--- reference during processing.
*
      DATA ICPLVL,ILOCCD,IMEDTP /0,1,2/
     +     ISTREC,IENREC,ISTBLK,IFLSIZ /0,0,0,0/
     +     ITIME /0/
     +     ITAPDN /200,556,800,1600,6250,0,38000/
     +     CFATFM /'FX'/
     +     CLABRQ(1,1),CLABRQ(1,2) /'HDR1','HDR2'/
     +     CLABRQ(2,1),CLABRQ(2,2) /'EOF1','EOF2'/
*
*--- Surpress error messages for error 219.
*
      CALL ERRSET(219,0,-1,1,1)
*
*--- Initialise Zebra,create short term divisions and set the log level.
*
      CALL MZEBRA(-3)
      CALL MZSTOR(IXSTOR,'/CRZT/','Q',IFENCE,LEV,BLVECT(1),BLVECT(1),
     +            BLVECT(5000),BLVECT(LURCOR))
      CALL MZLOGL(IXSTOR,IXDIN,'USERS',50000,LURCOR,'L')
*
*--- Define user link area.
*
      CALL MZLINK(IXSTOR,'/USRLNK/',LUSRK1,LUSRLS,LUSRK1)
*
*--- Set unit numbers for the RZ database.
*
      LUNRZ = 1
      LUNFZ = 2
*
*--- Initialise FATMEN for OPAL.
*
      CALL FMINIT(IXSTOR,LUNRZ,LUNFZ,'//CERN/OPAL',IRC)
*
*--- Read bank display option from the Tape VSN file,specifying whether
*--- each bank is to be displayed on the terminal for validation before
*--- committing it to FATMEN.
*
*     Modified 6/2/90 JDS
*     READ(IUNITC,FMT='(A7)',END=80) CBDISP
      READ(IUNITC,*,END=80)          NDISP
*
*--- If an invalid value has been supplied for the bank display option,
*--- then issue an error message and branch to terminate program
*--- execution.
*
*     IF (CBDISP.NE.'DISPLAY'.AND.CBDISP.NE.'NO DISP') THEN
*        PRINT*,' Invalid bank display option in tape VSN file.'
*        PRINT*,' '
*        PRINT*,' EXECUTION COMPLETED - NO PROCESSING HAS TAKEN PLACE.'
*        GO TO 90
*     ENDIF
*
*--- Loop to repeatedly read the filename of the next staged tape file
*--- from the file of Volume Serial Numbers and open it for subsequent
*--- processing.
*
10    CONTINUE
         READ(IUNITC,FMT='(A6)',END=80) CINVSN
         PRINT*,' PROCESSING TAPE FILE: ',CINVSN
         OPEN(IUNITA,FILE='/'//CINVSN//' FATINFO *')
         BERROR = .FALSE.
         BDIFF = .FALSE.
         NRECS = 0
*
*--- Loop to read and process successive labels(records) from the
*--- current tape file's header.
*
20       CONTINUE
            NRECS = NRECS + 1
*
*--- If an error has occured in reading the header labels or all labels
*--- have been read,then exit the loop.
*
            IF (BERROR.OR.NRECS.GT.3) GO TO 30
*
*--- Read a label or if the end of file is reached,branch to cease
*--- processing the current tape file.
*
            READ(IUNITA,FMT='(A)',END=70,IOSTAT=IOSTAT) CBUFF
*
*--- Store the label identifier.
*
            CLABEL = CBUFF(1:4)
*
*--- If the first label is being processed then test the label
*--- identifier for being that of the VOL1 label,storing the labels
*--- details or flaging an error accordingly.If the first label is not
*--- being processed then call HDRTRL to extract and store HDR1/HDR2
*--- details.
*
            IF (NRECS.EQ.1) THEN
*
               IF (CLABEL.EQ.'VOL1') THEN
                  CVLSLN = CBUFF(5:10)
               ELSE
                  BERROR = .TRUE.
               ENDIF
*
            ELSE
               CALL HDRTRL(CBUFF,CLABEL,CLABRQ(1,NRECS-1),NRECS-1,1,
     +                     BERROR)
            ENDIF
*
*--- If an error has occured in processing the header labels then issue
*--- the appropriate error message.
*
            IF (BERROR) THEN
               PRINT*,'    Error in processing HEADER'
               PRINT*,'    - missing or unexpected additional record.'
            ENDIF
 
*
*--- Loop back to read and process the next header label.
*
            GO TO 20
30       CONTINUE
*
*--- If an error occured in processing the header labels then branch to
*--- cease processing the current tape file.
*
         IF (BERROR) GO TO 70
*
*--- Loop to repeatedly read Tape file data records,until encountering
*--- the first trailer label or end of file marker.In the latter case
*--- the program branches to the data processing section and does not
*--- attempt to read and store trailer label fields.
*
35       CONTINUE
            READ(IUNITA,FMT='(A)',END=65) CBUFF
            IF (CBUFF(1:4).EQ.'EOF1') GO TO 40
            GO TO 35
40       CONTINUE
*
*--- Loop to read and process successive labels from the Tape file's
*--- trailer.This procedure is almost identical to that employed to
*--- read header labels,except that a VOL1 label is not expected.
*
         NRECS = 1
50       CONTINUE
            CLABEL = CBUFF(1:4)
            CALL HDRTRL(CBUFF,CLABEL,CLABRQ(2,NRECS),NRECS,2,BERROR)
*
            IF (BERROR) THEN
               PRINT*,'    Error in proecssing TRAILER'
               PRINT*,'    - missing or unexpected additional record.'
               GO TO 60
            ENDIF
*
            READ(IUNITA,FMT='(A)',END=60) CBUFF
            NRECS = NRECS + 1
            IF (NRECS.GT.2.OR.BERROR) GO TO 60
            GO TO 50
60       CONTINUE
*
*--- If an error occured in processing the trailer labels then branch
*--- to cease processing the current tape file.
*
         IF (BERROR) GO TO 70
*
*--- Call function BINTCM for each array containing 2 corresponding
*--- integer fields,taken from the HDR1 and EOF1(if it existed,
*--- otherwise 0's are contained in the appropriate positions) labels.
*--- The function returns a boolean value,depicting whether the 2 fields
*--- differ or not.
*
         BDIFF = BINTCM(IVLSQN,BDIFF)
         BDIFF = BINTCM(IDSSQN,BDIFF)
         BDIFF = BINTCM(ICRDAT,BDIFF)
         BDIFF = BINTCM(IBLKCT,BDIFF)
*
*--- Perform the same test as BINTCM on the character array CRECFT.
*
         IF (CRECFT(1).EQ.' ') THEN
            IF (CRECFT(2).NE.' ') CRECFT(1) = CRECFT(2)
         ELSE
         IF (CRECFT(1).NE.CRECFT(2).AND.CRECFT(2).NE.' ') BDIFF = .TRUE.
         ENDIF
*
*--- If an EOF2 label existed then perform similar comparisons between
*--- the corresponding fields of the HDR2 and EOF2 labels,setting a flag
*--- if they differ.
*
         IF (NRECS.EQ.2) THEN
            IF (CDATID(1).NE.CDATID(2)) BDIFF = .TRUE.
            IF (IBLKLN(1).NE.IBLKLN(2)) BDIFF = .TRUE.
            IF (IRECLN(1).NE.IRECLN(2)) BDIFF = .TRUE.
            IF (ITAPDV(1).NE.ITAPDV(2)) BDIFF = .TRUE.
         ENDIF
*
*--- If the information extracted from the header and trailer is
*--- inconsistant,then issue an error message and branch to cease
*--- processing the current tape file.
*
         IF (BDIFF) THEN
            PRINT*,'    HEADER-TRAILER information not consistant'
            PRINT*,'    - details have not been stored.'
            GO TO 70
         ENDIF
*
65       CONTINUE
*
*--- Call subroutine GETTAP to locate and read the relevent details from
*--- the appropriate entry in the Run Information file.The identifier
*--- for such details being the Tape file's Volume Serial Number.A flag
*--- is returned to indicate the success of GETTAP's search.
*
         CALL GETTAP(IUNITB,CVLSLN,CVISID,CGNAME,IDUMMY,CDETOT,CCOM1,
     +               CCOM2,BERROR)
*
*--- If an entry has not been located then branch to cease processing
*--- the current tape(an error message having already been issued by
*--- GETTAP).
*
         BERROR = .NOT.BERROR
         IF (BERROR) GO TO 70
*
*--- Call subroutine CONCAT to pack the 3 comment fields returned by
*--- GETTAP into a single field,for insertion into the FATMEN file
*--- catalogue.
*
         CALL CONCAT(CDETOT,CCOM1,CCOM2,COMMNT)
*
*--- Set a pointer to the end of the Generic filename returned by GETTAP
*
         IPTRG = INDEX(CGNAME,' ')
         IF (IPTRG.EQ.0) IPTRG = 55
*
*--- Create a new ZEBRA bank for the current tapes' data set,with a
*--- Generic name consisting of the concatenation of the string
*--- '//CERN/OPAL' and the Generic file name returned by GETTAP.
*
         CALL FMLIFT('//CERN/OPAL/'//CGNAME(1:IPTRG-1),KEYS,'3480','U'
     +               ,IRC)
*
*--- Derive the address of the bank and associate it with the Generic
*--- name.
*
         CALL FMLINK('//CERN/OPAL/'//CGNAME(1:IPTRG-1),LFAT,IRC)
*
*--- Fill some fields of the bank with the values held for them in the
*--- the tape data set variables/arrays,with the aid of the previously
*--- defined bank offsets and the subroutine UCTOH(for char/hollerith
*--- variables).Those fields not corresponding to tape data set
*--- variables/arrays are left holding the defaults assigned by
*--- FMLIFT.
*
         CALL UCTOH(CDATID(1),IQ(LFAT+MFQNFA),4,17)
         IQ(LFAT+MCPLFA) = ICPLVL
         IQ(LFAT+MLOCFA) = ILOCCD
         IQ(LFAT+MMTPFA) = IMEDTP
         CALL UCTOH(CVLSLN,IQ(LFAT+MVSNFA),4,6)
         CALL UCTOH(CVISID,IQ(LFAT+MVIDFA),4,6)
         IQ(LFAT+MDENFA) = ITAPDN(ITAPDV(1)+1)
         IQ(LFAT+MVSQFA) = IVLSQN(1)
         IQ(LFAT+MFSQFA) = IDSSQN(1)
         IQ(LFAT+MSRDFA) = ISTREC
         IQ(LFAT+MERDFA) = IENREC
         IQ(LFAT+MSBLFA) = ISTBLK
         IQ(LFAT+MEBLFA) = IBLKCT(1)
         CALL UCTOH(CRECFT(1),IQ(LFAT+MRFMFA),4,1)
         IQ(LFAT+MRLNFA) = IRECLN(1)
         IQ(LFAT+MBLNFA) = IBLKLN(1)
         IQ(LFAT+MFSZFA) = IFLSIZ
         CALL UCTOH(CFATFM,IQ(LFAT+MFLFFA),4,4)
         CALL FATDAT(ICRDAT(1),IDATE)
         CALL FMPKTM(IDATE,ITIME,IPACK,IRC)
         IQ(LFAT+MCRTFA) = IPACK
         CALL UCTOH(COMMNT,IQ(LFAT+MUCMFA),4,80)
*
*--- Consider the bank display option and either display or don't
*--- display the new ZEBRA bank accordingly.
*
*        IF (CBDISP.EQ.'DISPLAY') THEN
         IF (NSHOWN.LT.NDISP) THEN
            CALL DZSHOW('ZEBRA BANK',IXSTOR,LFAT,'B',0,0,0,0)
            PRINT*,' '
            NSHOWN = NSHOWN + 1
         ENDIF
*
*--- Commit the bank to FATMEN as a new file catalogue entry.
*
         CALL FMPUT('//CERN/OPAL/'//CGNAME(1:IPTRG-1),LFAT,IRC)
*
*--- Rewind the Run Information file and close the current Tape file,
*--- before returning to read and process the next Tape file.
*
         REWIND IUNITB
         CLOSE(IUNITA)
         GO TO 10
*
*--- If an error occurred during the processing of the current tape,then
*--- this piece of code is branched to,in order to issue an error
*--- message before preparing and returning to read the next Tape file.
*
70    CONTINUE
         IF (IOSTAT.LT.0) THEN
            PRINT*,'    Error in commencing procesing'
            PRINT*,'    - file is either empty or non-existant.'
         ENDIF
         PRINT*,' ATTEMPTING TO CONTINUE.....'
         PRINT*,' '
         REWIND IUNITB
         CLOSE(IUNITA)
         GO TO 10
80    CONTINUE
*
*--- Termination sequence
*
      PRINT*,' PROCESSING COMPLETED'
90    CONTINUE
      STOP
      END
*
*
      BLOCK DATA TAPEVR
*...TAPEVR
*.    Block data subprogram to initialise the named common blocks of
*.    TAPDL1 and TAPDL2.
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : G.J.Barlow
*. VERSION    :
*. CREATED    : 02-Nov-89
*. LAST MOD   :
*.
*. Modification Log
*.
*.**********************************************************************
*.
      INTEGER IBLKLN(2),IRECLN(2),ITAPDV(2)
      INTEGER IVLSQN(2),IDSSQN(2),ICRDAT(2),IBLKCT(2)
      CHARACTER*17 CDATID(2)
      CHARACTER*1 CRECFT(2)
*
      COMMON /TAPDL1/ CDATID,CRECFT
      COMMON /TAPDL2/ IBLKLN,IRECLN,ITAPDV,IVLSQN,IDSSQN,ICRDAT,IBLKCT
*
*--- Initialise the array elements intended to hold the EOF1 tape
*--- details and assign defaults to those intended to hold the HDR2 and
*--- EOF2 details.
*
      DATA CDATID(2) /' '/
     +     IVLSQN(2),IDSSQN(2),ICRDAT(2),IBLKCT(2) /0,0,0,0/
     +     CRECFT /'U','U'/
     +     IBLKLN /3600,3600/
     +     IRECLN /3600,3600/
     +     ITAPDV /6,6/
*
      END
*
*
      SUBROUTINE GETTAP(IUNITB,REFTAP,TAPNUM,GENAME,DATE,DETOUT,COM1,
     +                  COM2,BOOL)
*...GETTAP
*.    This subroutine processes the Run Information file, extracting
*.    the generic name and attributing the additional information to
*.    the relevant variable names.
*.
*. COMMON     :
*. SEQUENCE   :
*. CALLS      :
*. CALLED     : TAPELOAD
*.
*. BANKS L    :
*. BANKS U    :
*. BANKS M    :
*. BANKS D    :
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : P.A.Eccles
*. VERSION    :
*. CREATED    : 26-Oct-89
*. LAST MOD   :
*.
*. Modification Log.
*.
*.**********************************************************************
*.
      IMPLICIT NONE
      CHARACTER*80 LINE,DETOUT,COM1,COM2
      CHARACTER*54 GENAME
      CHARACTER*6  TAPNUM,REFTAP
      CHARACTER    FLAG,MARKER
      INTEGER      IUNITB,DATE,UWORDS,NOCOM
      LOGICAL      BOOL
 
************************************************************************
*
* VARIABLE DESCRIPTIONS::-
*
*        CHARACTER:-
*             LINE       =  File record
*             DETOUT     =  Comment on the detectors not working
*                           when the tape was taken
*             COM1,COM2  =  User comments on the tapes contents
*             GENAME     =  Generic tape name
*             TAPNUM     =  Tape number from the label
*             REFTAP     =  Tape number being requested
*             FLAG       =  Symbol of a comment being of type DETOUT
*             MARKER     =  Tempory store to hold a records first
*                           character to see if it matches to the FLAG
*             BOOL       =  Boolian marker for a tapes presence
*                           within the input file
*
*        INTEGER:-
*             IUNITB     =  Unit number associated with the input file
*             DATE       =  Tapes creation date
*             UWORDS     =  Number of comment records following
*             NOCOM      =  Integer boolian for a comments presence
*
*        LOGICAL:-
*             BOOL       =  Boolian marker for a tapes presence
*                           within the input file
*
************************************************************************
 
* --- Initalise the data names
      LINE   = ' '
      DETOUT = ' '
      COM1   = ' '
      COM2   = ' '
      GENAME = ' '
      TAPNUM = ' '
      MARKER = ' '
      FLAG   = '@'
      UWORDS = 0
      DATE   = 0
      NOCOM  = 0
      BOOL   = .FALSE.
 
* --- Format definitions
90    FORMAT (A80)
100   FORMAT (A6,4X,A54,16X)
110   FORMAT (10X,I1,11X,I6,52X)
 
* --- Main program
120   CONTINUE
      READ (IUNITB,FMT = 90,END=150) LINE
      READ (LINE,FMT = '(A6)') TAPNUM
      IF (TAPNUM.EQ.REFTAP) THEN
         BOOL = .TRUE.
         READ (LINE,FMT = '(10X,A54)') GENAME
         READ (IUNITB,FMT = 110,END=140) UWORDS, DATE
         IF (UWORDS.EQ.0) THEN
            DETOUT = 'No detectors out.'
            COM1   = 'No comments.'
            COM2   = ' '
            GO TO 150
         ENDIF
         IF (UWORDS.EQ.1) THEN
            READ (IUNITB,FMT= 90,END=140) LINE
            READ (LINE,FMT='(A1)') MARKER
            IF (MARKER.EQ.FLAG) THEN
               WRITE (DETOUT,FMT='(A79)') LINE(2:80)
               COM1 = 'No comments.'
               COM2 = ' '
            ELSE
               IF ((LINE(11:14).EQ.'LEPD').OR.(LINE(11:14).EQ.'COSM')
     +         .OR.(LINE(11:14).EQ.'SIMD')) THEN
                  NOCOM = 1
                  GO TO 130
               ELSE
                  DETOUT = 'No detectors out.'
                  WRITE (COM1,FMT=90) LINE
                  COM2   = ' '
               ENDIF
            ENDIF
         ENDIF
         IF (UWORDS.EQ.2) THEN
            READ (IUNITB,FMT= 90,END=140) LINE
            READ (LINE,FMT='(A1)') MARKER
            IF (MARKER.EQ.FLAG) THEN
               WRITE (DETOUT,FMT='(A79)') LINE(2:80)
               READ (IUNITB,FMT=90,END=140) LINE
               IF ((LINE(11:14).EQ.'LEPD').OR.(LINE(11:14).EQ.'COSM')
     +         .OR.(LINE(11:14).EQ.'SIMD')) THEN
                  NOCOM = 1
                  GO TO 130
               ELSE
                  WRITE (COM1,FMT=90) LINE
                  COM2 = ' '
               ENDIF
            ELSE
               IF ((LINE(11:14).EQ.'LEPD').OR.(LINE(11:14).EQ.'COSM')
     +         .OR.(LINE(11:14).EQ.'SIMD')) THEN
                  NOCOM = 1
                  GO TO 130
               ELSE
                  DETOUT = 'No detectors out.'
                  WRITE (COM1,FMT= 90) LINE
               ENDIF
               READ (IUNITB,FMT= 90,END=140) LINE
               IF ((LINE(11:14).EQ.'LEPD').OR.(LINE(11:14).EQ.'COSM')
     +         .OR.(LINE(11:14).EQ.'SIMD')) THEN
                  NOCOM = 1
                  GO TO 130
               ELSE
                  WRITE (COM2,FMT= 90) LINE
               ENDIF
            ENDIF
         ENDIF
         IF (UWORDS.EQ.3) THEN
            READ (IUNITB,FMT= 90,END=140) LINE
            IF ((LINE(11:14).EQ.'LEPD').OR.(LINE(11:14).EQ.'COSM')
     +      .OR.(LINE(11:14).EQ.'SIMD')) THEN
               NOCOM = 1
               GO TO 130
            ELSE
               WRITE (DETOUT,FMT='(A79)') LINE(2:80)
            ENDIF
            READ (IUNITB,FMT= 90,END=140) LINE
            IF ((LINE(11:14).EQ.'LEPD').OR.(LINE(11:14).EQ.'COSM')
     +      .OR.(LINE(11:14).EQ.'SIMD')) THEN
               NOCOM = 1
               GO TO 130
            ELSE
               WRITE (COM1,FMT= 90) LINE
            ENDIF
            READ (IUNITB,FMT= 90,END=140) LINE
            IF ((LINE(11:14).EQ.'LEPD').OR.(LINE(11:14).EQ.'COSM')
     +      .OR.(LINE(11:14).EQ.'SIMD')) THEN
               NOCOM = 1
               GO TO 130
            ELSE
               WRITE (COM2,FMT= 90) LINE
            ENDIF
         ENDIF
      ELSE
         GO TO 120
      ENDIF
 
* --- Error message when a comment isn't found when UWORDS > 0
130   CONTINUE
      IF (NOCOM.EQ.1) PRINT*,' Comment not found when expected tape ',
     +                       REFTAP
 
* --- Error message when a comment isn't found when UWORDS > 0 at EOF
140   CONTINUE
      IF (LINE.EQ.' ') PRINT*,' Comment not found when expected tape ',
     +                       REFTAP
 
150   CONTINUE
      END
*
*
      SUBROUTINE HDRTRL(CBUFF,CLABEL,CLABRQ,NRECS,ISUB,BERROR)
*...HDRTRL
*.    Subroutine to extract and store the relevant details from either
*.    of the 2 header labels,HDR1 and HDR2,or either of the 2 trailer
*.    labels,EOF1 and EOF2.The label itself is supplied as a parameter,
*.    along with the identifier of the label type expected.If the
*.    expected label is not discovered then no tape details will be
*.    extracted and in the case of a HDR1 label,an error message given.
*.    Note that the HDR1 and EOF1,HDR2 and EOF2 labels should contain
*.    the same information and this is duplicated in storage for later
*.    consistancy comparisons.
*.
*. COMMON     :
*. SEQUENCE   :
*. CALLS      :
*. CALLED     : TAPELOAD
*.
*. BANKS L    :
*. BANKS U    :
*. BANKS M    :
*. BANKS D    :
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : G.J.Barlow
*. VERSION    :
*. CREATED    : 02-Nov-89
*. LAST MOD   :
*.
*. Modification Log.
*.
*.**********************************************************************
*.
      INTEGER NRECS,ISUB
      CHARACTER*80 CBUFF
      CHARACTER*4 CLABEL,CLABRQ
      LOGICAL BERROR
*
      INTEGER IBLKLN(2),IRECLN(2),ITAPDV(2)
      INTEGER IVLSQN(2),IDSSQN(2),ICRDAT(2),IBLKCT(2)
      CHARACTER*17 CDATID(2)
      CHARACTER*1 CRECFT(2)
      REAL RRECLN,RBLKLN
*
      COMMON /TAPDL1/ CDATID,CRECFT
      COMMON /TAPDL2/ IBLKLN,IRECLN,ITAPDV,IVLSQN,IDSSQN,ICRDAT,IBLKCT
*
*--- If the first header/trailer label is being processed,check for the
*--- derived and expected label identifiers matching.If so,the approp-
*--- riate label character positions are read from and stored.Otherwise
*--- an error is flaged.
*
      IF (NRECS.EQ.1) THEN
*
         IF (CLABEL.EQ.CLABRQ) THEN
            CDATID(ISUB) = CBUFF(5:21)
            READ(CBUFF(28:31),FMT='(I4)') IVLSQN(ISUB)
            READ(CBUFF(32:35),FMT='(I4)') IDSSQN(ISUB)
            READ(CBUFF(42:47),FMT='(I6)') ICRDAT(ISUB)
            READ(CBUFF(55:60),FMT='(I6)') IBLKCT(ISUB)
         ELSE
            BERROR = .TRUE.
         ENDIF
*
*--- The same procedure is adopted for the second header/trailer label,
*--- except that no error is registered for missing labels(the HDR2 and
*--- EOF2 labels are permitted not to exist).
*
      ELSE IF (NRECS.EQ.2.AND.CLABEL.EQ.CLABRQ) THEN
         CRECFT(ISUB) = CBUFF(5:5)
         READ(CBUFF(6:10),FMT='(F5.0)') RBLKLN
         IBLKLN(ISUB) = INT(RBLKLN/4)
         READ(CBUFF(11:15),FMT='(F5.0)') RRECLN
         IRECLN(ISUB) = INT(RRECLN/4)
         READ(CBUFF(16:16),FMT='(I1)') ITAPDV(ISUB)
      ENDIF
*
      END
*
*
      SUBROUTINE CONCAT(CDETOT,CCOM1,CCOM2,COMMNT)
*...CONCAT
*.    Subroutine to pack as many characters as possible from 3 comment
*.    fields of 80 bytes in length,into a single 80 byte FATMEN comment
*.    field.This involves regarding comment fields 1-3 as having
*.    descending priority,removing the trailing spaces from each comment
*.    field and inserting a seperating character string to distinguish
*.    the 3 original comment fields.
*.
*. COMMON     :
*. SEQUENCE   :
*. CALLS      : IPOINT
*. CALLED     : TAPELOAD
*.
*. BANKS L    :
*. BANKS U    :
*. BANKS M    :
*. BANKS D    :
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : G.J.Barlow
*. VERSION    :
*. CREATED    : 02-Nov-89
*. LAST MOD   :
*.
*. Modification Log.
*.
*.**********************************************************************
*.
      CHARACTER*80 CDETOT,CCOM1,CCOM2,COMMNT
      INTEGER IPTR1,IPTR2,IPTR3,ICPTR
*
*--- Set pointers to the end of the 3 comment fields,by identifying the
*--- position of the terminating string,'  ',within them.
*
      IPTR1 = INDEX(CDETOT,'  ')
      IPTR2 = INDEX(CCOM1,'  ')
      IPTR3 = INDEX(CCOM2,'  ')
*
      ICPTR = 1
      COMMNT = ' '
*
*--- If the 1st comment field contains a value then store it within the
*--- packed comment field and set a pointer to it's last character
*--- position.The function IPOINT is called if the 1st comment fields
*--- end pointer is set to 0(ie it could be either 79 or 80 chars in
*--- length),to derive the correct end pointer value.
*
      IF (IPTR1.NE.1) THEN
         IF (IPTR1.EQ.0) IPTR1 = IPOINT(IPTR1,CDETOT)
         COMMNT(ICPTR:IPTR1-1) = CDETOT(1:IPTR1-1)
         ICPTR = IPTR1
      ENDIF
*
*--- Repeat testing and storage procedure for 2nd comment field,
*--- inserting a seperating string into the packed comment field if a
*--- 1st comment field existed.
*
      IF (IPTR2.NE.1.AND.ICPTR.LT.81) THEN
         IF (IPTR2.EQ.0) IPTR2 = IPOINT(IPTR2,CCOM1)
         IF (IPTR1.NE.1) COMMNT(ICPTR:ICPTR+2) = ' - '
         ICPTR = ICPTR + 3
*
         IF (IPTR2-1.GT.(81-ICPTR)) THEN
            COMMNT(ICPTR:80) = CCOM1(1:(81-ICPTR))
            ICPTR = 81
         ELSE
            COMMNT(ICPTR:(ICPTR+IPTR2-2)) = CCOM1(1:IPTR2-1)
            ICPTR = IPTR2
*
*--- Repeat testing and storage procedure for the 3rd comment field but
*--- only if a 2nd comment field existed.
*
            IF (IPTR3.NE.1.AND.ICPTR.LT.81) THEN
               IF (IPTR2.EQ.0) IPTR3 = IPOINT(IPTR3,CCOM2)
               COMMNT(ICPTR:ICPTR+2) = ' - '
               ICPTR = ICPTR + 3
*
               IF (IPTR3-1.GT.(81-ICPTR)) THEN
                  COMMNT(ICPTR:80) = CCOM2(1:(81-ICPTR))
               ELSE
                  COMMNT(ICPTR:(ICPTR+IPTR3-2)) = CCOM2(1:IPTR3-1)
               ENDIF
*
            ENDIF
*
         ENDIF
*
      ENDIF
*
      END
*
*
      SUBROUTINE FATDAT(JDATE,IDATE)
*...FATDAT
*.    Subroutine to accept a Julian date of the form YYDDD and convert
*.    it to the more conventional YYMMDD format.The latter format is the
*.    one expected by the DBPKTM subroutine,used to produce a packed
*.    date and time value for the Creation Date field of the file
*.    catalogue.The Julian date format is supplied by the HDR1 label of
*.    each files header.
*.
*. COMMON     :
*. SEQUENCE   :
*. CALLS      : UCOPY
*. CALLED     : TAPELOAD
*.
*. BANKS L    :
*. BANKS U    :
*. BANKS M    :
*. BANKS D    :
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : J.D.Shiers
*. VERSION    :
*. CREATED    :
*. LAST MOD   :
*.
*. Modification Log.
*.
*.**********************************************************************
*.
      INTEGER NDAYS(12),NLEAP(12)
      CHARACTER*36 MONTHS
*
      DATA MONTHS/'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'/
      DATA NDAYS/00,31,59,90,120,151,181,212,243,273,304,334/
      DATA NLEAP/00,31,60,91,121,152,182,213,244,274,305,335/
*
*--- Seperate and store the year and day components of the Julian date.
*
      IYEAR = JDATE / 1000
      IDAY  = JDATE - (IYEAR * 1000)
*
*--- Test for the year being one of the 4 recognised leap years and if
*--- so,call the subroutine UCOPY to copy the cumulative day totals from
*--- the leap year 'month' array,into the non-leap year 'month' array.
*
      IF (IYEAR .EQ. 84 .OR. IYEAR .EQ. 88 .OR.
     +    IYEAR .EQ. 92 .OR. IYEAR .EQ. 96) CALL UCOPY(NLEAP,NDAYS,12)
      IMON = 12
*
*--- Loop to identify the month in which the Julian day lies.
*
      DO 160 I=1,11
*
*--- If the Julian day lies between the current and the next months
*--- cumulative day limits,then store the current month and calculate
*--- and store the correct day of the month.
*
         IF ( IDAY .GT. NDAYS(I) .AND. IDAY .LE. NDAYS(I+1) ) THEN
            IMON  = I
            IDAY  = IDAY - NDAYS(I)
         ENDIF
*
160   CONTINUE
*
*--- Assemble and store the calculated components of the conventional
*--- date.
*
      IF ( IMON .EQ. 12) IDAY = IDAY - NDAYS(12)
      IDATE = IYEAR*10000 + IMON * 100 + IDAY
      RETURN
 
      END
*
*
      LOGICAL FUNCTION BINTCM(IARRAY,BDIFF)
*...BINTCM
*.    Function to compare corresponding integer fields from the HDR1
*.    and EOF1 labels of a staged tape file.The comparison will only be
*.    made if the 2 fields both hold non-zero values(ie both labels have
*.    been supplied and values for both fields supplied).If the above is
*.    true and the values differ then a flag is set to indicate this.If
*.    however,the HDR1 field is 0 and the EOF1 field contains a value,
*.    the value is copied into the HDR1 field,for later insertion into
*.    the FATMEN file catalogue.
*.
*. COMMON     :
*. SEQUENCE   :
*. CALLS      :
*. CALLED     : TAPELOAD
*.
*. BANKS L    :
*. BANKS U    :
*. BANKS M    :
*. BANKS D    :
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : G.J.Barlow
*. VERSION    :
*. CREATED    : 02-Nov-89
*. LAST MOD   :
*.
*. Modification Log.
*.
*.**********************************************************************
*.
      INTEGER IARRAY(2)
      LOGICAL BDIFF
 
      BINTCM = BDIFF
*
      IF (IARRAY(1).EQ.0) THEN
         IF (IARRAY(2).NE.0) IARRAY(1) = IARRAY(2)
      ELSE
         IF (IARRAY(1).NE.IARRAY(2).AND.IARRAY(2).NE.0) BINTCM = .TRUE.
      ENDIF
 
      END
*
*
      INTEGER FUNCTION IPOINT(IPTRN,CSTRNG)
*...IPOINT
*.    Function to accept a comment character string,which may be a
*.    maximum of N bytes in length,identify it as being of N or N-1
*.    bytes in length and set a length pointer accordingly.The pointer
*.    is set to N+1 in the first instance and N-1 in the second,before
*.    being returned as the functions value.This function is necessary
*.    as the string length will register zero,in both of the above cases
*.    ,when the terminating sting,'  ',is searched for.
*.
*. COMMON     :
*. SEQUENCE   :
*. CALLS      :
*. CALLED     : CONCAT
*.
*. BANKS L    :
*. BANKS U    :
*. BANKS M    :
*. BANKS D    :
*.
*. REPORT CONDITIONS
*.
*. AUTHOR     : G.J.Barlow
*. VERSION    :
*. CREATED    : 02-Nov-89
*. LAST MOD   :
*.
*. Modification Log.
*.
*.**********************************************************************
*.
      INTEGER IPTRN
      CHARACTER*80 CSTRNG
 
      IF (CSTRNG(80:80).EQ.' ') THEN
         IPOINT = IPTRN - 1
      ELSE
         IPOINT = 81
      ENDIF
 
      END
