C   05/10/82 403081420  MEMBER NAME  KALIB    (JADESR)      FORTRAN
      SUBROUTINE KALCOP(INPU,IOUT)
      IMPLICIT INTEGER*2 (H)
C---
C---     SIMPLE COPY.
C---                                   L.H. O'NEILL 10.09.79
C---
      DIMENSION JBUF(10000),IDAT(9991),HBUF(20000),ITIME(6),NAME( 9)
      EQUIVALENCE(JBUF(1),HBUF(1))
      EQUIVALENCE(JBUF(10),IDAT(1))
      DATA NAME/'MUCA','LGMA','TAGS','JTPL','JTAB','TOFC','LGST','DEDX',
     1          'SPTG'/
C---
      NREC=0
    1 CONTINUE
      CALL EVREA1(INPU,NWORD,JBUF,IRET)
      IF(IRET.EQ.1) GO TO 1000
      IF(IRET.EQ.2) GO TO 2000
      NREC=NREC+1
C
C
C     IF(NWORD.LE. 9) GOTO 10
C     IF(JBUF(8).GT. 0) GOTO 10
C        ITIM = JBUF(6)
C        CALL CVDTRN(IRUN,ITIM)
C        JBUF(8) = IRUN
   10 CONTINUE
      IF(JBUF(1).EQ.NAME(2) .AND. JBUF(8).EQ.   0) JBUF(8) = JBUF(6)
   50 CONTINUE
      CALL KALBNK(IOUT,NWORD,JBUF)
      GO TO 1
 1000 CONTINUE
      WRITE(6,101) NREC
  101 FORMAT(' *** READ ERROR ENCOUNTERED AFTER ',I4,' RECORDS.',
     +'     (KALCOP F 101)')
      RETURN
 2000 CONTINUE
      WRITE(6,102) INPU,NREC
  102 FORMAT('0NORMAL EOF ON UNIT #',I2,' AFTER',I6,' RECORDS',
     +'  -  DSN=F11LHO.KALWRK0',10X,'(KALCOP F 102)')
      RETURN
      END
      SUBROUTINE KORDER
      IMPLICIT INTEGER*2 (H)
C---
C---     PUTS CALIBRATION UPDATE RECORDS INTO INCREASING TIME ORDER.
C---     INPUT/OUTPUT: UNIT #8/#9
C---                                   W.BARTEL  18.09.82
C---
      DIMENSION JBUF(10000),IDAT(9991),HBUF(20000),ITIME(6),NAME( 7)
      DIMENSION HTIME(6),HDAT(3),HCAT(1)
      COMMON/CORDER/NRECW,LIST(2,10000)
      EQUIVALENCE(JBUF(1),HBUF(1))
      EQUIVALENCE(JBUF(10),IDAT(1))
      EQUIVALENCE(HDAT(1),IDAT(1))
      EQUIVALENCE(HCAT(1),HDAT(3))
      DATA NAME/'MUCA','LGMA','TAGS','JTPL','JTAB','TOFC','LGST'/
C---
C---
C---     READ NEW RECORD(S) FROM UNIT 8
C---
      IWFLAG=1
      ITIME(1)=0
      ITIME(2)=0
      ITIME(3)=0
      ITIME(4)=1
      ITIME(5)=1
      ITIME(6)=1979
      LASTIM=0
      IDMTIM=KTMCON(ITIME,KTWRIT,LASTIM)
C---
      JBUF(1)=NAME(7)
      JBUF(2)=1
      JBUF(3)=1
      JBUF(4)=0
      JBUF(5)=KTWRIT
      JBUF(6)=0
      JBUF(7)=1
      JBUF(8)=0
      JBUF(9)=0
      NREC=0
      NRECW=0
      REWIND 4
      REWIND 8
    4 CONTINUE
      CALL EVREAH(8,NWORDH,HCAT,IRET)
      IF(IRET.EQ.1) GO TO 1001
      IF(IRET.EQ.2) GO TO 2001
C     IF (NREC.LE.5)
C    +PRINT 2901, (HCAT(II),II=1,10)
 2901 FORMAT (1X,10I10,'     (KORDER F 2901)')
      NREC=NREC+1
      GO TO 5
 1001 CONTINUE
      WRITE(6,201) NREC
  201 FORMAT(' *** READ ERROR ENCOUNTERED AFTER ',I8,' RECORDS. (8)',
     +'     (KORDER F 201)')
      STOP
C---
C---     SELECT RECORDS FROM INPUT UNIT(S).
C---
    5 IDAT(1)=NWORDH
C     IF (NREC.LE.5)
C    +PRINT 2905, (IDAT(II),II=1,8)
 2905 FORMAT (1X,8I10,'     (KORDER F 2905)')
         IF(IDAT(1).LE.10) GO TO 4
         IF(IDAT(2).LE.500) GO TO 4
C         IDAT(1)=LENG, IDAT(2)=#EV.  BETTER BE NO DATA THAN
C         HAVING SHORT DATA.
      NWORDH=NWORDH+2
      ITIME(1)=HCAT(5)
      ITIME(2)=HCAT(6)
      ITIME(3)=HCAT(7)
      ITIME(4)=HCAT(8)
      ITIME(5)=HCAT(9)
      ITIME(6)=HCAT(10)
      LASTIM=0
      JBUF(6)=KTMCON(ITIME,KTDUMM,LASTIM)
      IF(JBUF(6).EQ.0) GO TO 4
C---
C---     SUBTRACT 200 SECONDS FROM EFFECTIVE TIME TO MAKE SURE CHANGE
C---     GOES INTO EFFECT AT START OF RUN.
C---
      JBUF(6)=JBUF(6)-200
C---     SET RUN #
      JBUF(8)=HCAT(4)
      NWORD=NWORDH/2
      IF((2*NWORD).NE.NWORDH) NWORD=NWORD+1
      NWORD=NWORD+9
      NRECW=NRECW+1
C---     WRITE OUT RECORDS TO UNIT 4 (SCRATCH)
C---     FILL LIST ARRAY FOR ORDERING
      IF(NRECW.GT.10000) WRITE(6,203)
  203 FORMAT(' **** ERROR. MORE THEN 10000 RECORDS. PROGRAMMED STOP.',
     +'     (KORDER F 203)')
      IF(NRECW.GT.10000) STOP
      LIST(1,NRECW)=NRECW
      LIST(2,NRECW)=JBUF(6)
C     IF (NREC.LE.5)
C    +PRINT 2902, (JBUF(II),II=1,10)
 2902 FORMAT (1X,10I10,'     (KORDER F 2902)')
      CALL KALBNK(4,NWORD,JBUF)
      GO TO 4
 2001 CONTINUE
      WRITE(6,202) NREC, NRECW
  202 FORMAT('0NORMAL EOF ON UNIT # 8 AFTER',I6,' RECORDS  -  ',
     +'BAD CHANNEL SCRATCH FILE    (KORDER F 202)'/'0'28X,I6,
     +' RECORDS FROM UNIT # 8 ACCEPTED')
C---     ORDER ARRAY LIST ACCORDING TO TIME = LIST(2)
C---     USE SHELL ALGORITHM
C        WRITE(6,1991) ((LIST(KLM,LHO),KLM=1,2),LHO=1,50)
 1991    FORMAT(1X,2I10,
     +'        (KORDER F 1991)')
C
      IF(NRECW.NE.0) GOTO 9
      WRITE(6,306)
  306 FORMAT(' *** PROGRAMMED STOP *** NO BAD CHANNELS FOUND',
     +'     (KORDER F 306)')
C
    9 N=NRECW
      M=N
   12 M=M/2
      IF (M.EQ.0) GOTO 11
      K=N-M
      DO 14 J=1,K
      I=J
   13 IF (I.LT.1) GOTO 14
      IF (LIST(2,I+M).GE.LIST(2,I)) GOTO 14
      LW2=LIST(2,I)
      LW1=LIST(1,I)
      LIST(2,I)=LIST(2,I+M)
      LIST(1,I)=LIST(1,I+M)
      LIST(2,I+M)=LW2
      LIST(1,I+M)=LW1
      I=I-M
      GOTO 13
   14 CONTINUE
      GOTO 12
   11 CONTINUE
C -----------------------
C        WRITE(6,1998)
 1998    FORMAT(' ')
C        WRITE(6,1992) ((LIST(KLM,LHO),KLM=1,2),LHO=1,50)
 1992    FORMAT (1X,2I10,
     +'         (KORDER F 1992)')
    6 CONTINUE
C--     LIST ARRAY IS NOW TIME ORDERED
C--     READ UNIT # 4  PUT TIME ORDERED RECORDS ONTO UNIT # 9
C--
      REWIND 4
      REWIND 9
      NCURNT=0
      LASTIW=0
      DO 10 I=1,NRECW
C     IF (I.LE.10)
C    +    WRITE(6,1995) I,NCURNT,LIST(1,I),LIST(2,I)
 1995     FORMAT(' I,NCURNT,LIST(1,I),LIST(2,I)= ',4I10,
     +'         (KORDER F 1995)')
      NWISH=LIST(1,I)
      IF(NWISH.GT.NCURNT) GO TO 20
      REWIND 4
      DO 15 J=1,NWISH
      CALL EVREA1(4,NWORD,JBUF,IRET)
C     IF (J.LE.10.AND.I.LE.10)
C    +PRINT 2903, (JBUF(II),II=1,10)
 2903 FORMAT (1X,10I10,'     (KORDER F 2903)')
      IF(IRET.EQ.0) GO TO 15
      WRITE(6,205) IRET
  205 FORMAT(' *** ILLEGAL IRET = ',I2,' IN LOOP 15. STOP.',
     +'     (KORDER F 205)')
      STOP
   15 CONTINUE
      GO TO 16
   20 CONTINUE
      LOOP=NWISH-NCURNT
      DO 17 J=1,LOOP
      CALL EVREA1(4,NWORD,JBUF,IRET)
C     IF (J.LE.10.AND.I.LE.10)
C    +PRINT 2904, (JBUF(II),II=1,10)
 2904 FORMAT (1X,10I10,'     (KORDER F 2904)')
      IF(IRET.EQ.0) GO TO 17
      WRITE(6,207) IRET
  207 FORMAT(' *** ILLEGAL IRET = ',I2,' IN 7 LOOP. STOP.',
     +'     (KORDER F 207)')
      STOP
   17 CONTINUE
   16 CONTINUE
      NCURNT=NWISH
      IF(JBUF(6).EQ.LIST(2,I)) GO TO 18
      WRITE(6,204) I,JBUF(6),LIST(1,I),LIST(2,I)
  204 FORMAT(' JBUF(6) AND LIST(2,I) DISAGREE. DUMP = ',4I10,
     +'     (KORDER F 204)')
      WRITE(6,303)
  303 FORMAT(' *** PROGRAMMED STOP *** ',
     +'     (KORDER F 303)')
      STOP
   18 CONTINUE
      IF(JBUF(6).GE.LASTIW) GO TO 19
      WRITE(6,206) I,JBUF(6),LASTIW,LIST(1,I),LIST(2,I)
  206 FORMAT(' DECREASING TIME. DUMP = ',5I10,
     +'     (KORDER F 206)')
      WRITE(6,304)
  304 FORMAT(' *** PROGRAMMED STOP *** ',
     +'     (KORDER F 304)')
      STOP
   19 CONTINUE
      LASTIW=JBUF(6)
C     IF (I.LE.10)
C    +PRINT 2906, (JBUF(II),II=1,10)
 2906 FORMAT (1X,10I10,'     (KORDER F 2906)')
      IF(IWFLAG.EQ.1) CALL KALBNK(9,NWORD,JBUF)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE KALADD
      IMPLICIT INTEGER*2 (H)
C---
C---     FOR ADDING ON AND MODIFYING CALIBRATION RECORDS.
C---                                   W.BARTEL 22.09.82
      DIMENSION JBUF(10000),IDAT(9991),HBUF(20000),ITIME(6),NAME( 7)
      DIMENSION HTIME(6),HDAT(3),HCAT(1),JBUF1(10000)
      EQUIVALENCE(JBUF1(1),HBUF(1))
      EQUIVALENCE(JBUF1(10),IDAT(1))
      EQUIVALENCE(HDAT(1),IDAT(1))
      EQUIVALENCE(HCAT(1),HDAT(3))
      COMMON/CORDER/INSRT,LIST(2,10000)
C---
      NREC=0
      NREC1=0
      NREC2=0
      IFILL=1
C---
C---     LOOP OVER THE RECORDS ON THE EXISTING CALIBRATION FILE (UNIT 3)
C---     ADD ON NEW CALIBRATION DATA FROM UNIT 9 WRITE TO UNIT 4
C---
      REWIND 3
      REWIND 9
      REWIND 4
      IEOF=0
      NPRI=0
    1 CONTINUE
      NPRI=NPRI+1
      IF (IEOF.EQ.1) GOTO 5
      CALL EVREA1(3,NWORD,JBUF,IRET)
      IF(IRET.EQ.1) GO TO 1000
      IF(IRET.EQ.2) GO TO 2000
C     IF (NPRI.LE.5) PRINT 2901, (JBUF(II),II=1,10)
 2901 FORMAT (1X,10I10,'     (KALADD F 2901)')
C     IF (NPRI.LE.5) PRINT 2902, INSRT,IFILL,LIST(2,IFILL)
 2902 FORMAT (' INSRT,IFILL,LIST(2,IFILL)=',3I10,'     (KALADD F 2902)')
      NREC=NREC+1
C--      COPY DATA ONTO UNIT 4 UNLESS A UNIT 8 RECORD HAS TO BE
C--      INSERTED
      IF (IFILL.GT.INSRT) GOTO 4
    3 IF(JBUF(6).GE.LIST(2,IFILL)) GO TO 5
    4 CALL KALBNK(4,NWORD,JBUF)
      GO TO 1
 1000 CONTINUE
      WRITE(6,101) NREC
  101 FORMAT(' *** READ ERROR ENCOUNTERED AFTER ',I8,' RECORDS.',
     +'     (KALADD F 101)')
      STOP
 2000 CONTINUE
      IEOF=1
      WRITE(6,102) NREC
  102 FORMAT('0NORMAL EOF ON UNIT # 3 AFTER',I6,' RECORDS',
     +'     (KALADD F 102)')
      NPRI=0
C---
C---     ADD ON NEW RECORD(S) MADE FROM DATA ON UNIT 9 ETC.
C---     AND WRITE THESE TO UNIT 4 SCRATCH FILE.
C---
    5 CONTINUE
      CALL EVREA1(9,NWORD1,JBUF1,IRET)
      IF(IRET.EQ.1) GO TO 1001
      IF(IRET.EQ.2) GO TO 2001
C     IF (NREC1.LE.5) PRINT 2903, (JBUF1(II),II=1,10)
 2903 FORMAT (1X,10I10,'     (KALADD F 2903)')
      NREC1=NREC1+1
      IFILL = IFILL + 1
      IF (JBUF1(6).EQ.LIST(2,NREC1)) GOTO 8
      PRINT 2905, NREC1,JBUF1(6),LIST(1,NREC1),LIST(2,NREC1)
 2905 FORMAT (' JBUF(6) AND LIST(2,..) DISAGREE. DUMP = ',4I10,
     +'      (KALADD F 2905)')
    8 CALL KALBNK(4,NWORD1,JBUF1)
      IF(IFILL.GT.INSRT) GO TO 4
      IF(JBUF(6).GE.LIST(2,IFILL)) GO TO 5
      GO TO 4
 1001 CONTINUE
      WRITE(6,201) NREC1
  201 FORMAT(' *** READ ERROR ENCOUNTERED AFTER ',I8,' RECORDS. (TWO)',
     +'     (KALADD F 201)')
      STOP
 2001 CONTINUE
      WRITE(6,202) NREC1
  202 FORMAT('0NORMAL EOF ON UNIT # 9 AFTER',I6,' RECORDS',
     +'     (KALADD F 202)'/'0UNIT # 3 AND # 9 MERGED ONTO UNIT # 4')
      RETURN
      END
      SUBROUTINE KALREV
      IMPLICIT INTEGER*2 (H)
C---
C---     COPIES BACK FROM WORKING FILE TO AUPDAT...
C---     ELIMINATES DUPLICATE LGST BANKS.
C---                                   L.H. O'NEILL 20.02.80
C---
      DIMENSION JBUF(10000),IDAT(9991),HBUF(20000),ITIME(6),NAME( 7)
      EQUIVALENCE(JBUF(1),HBUF(1))
      EQUIVALENCE(JBUF(10),IDAT(1))
      DATA NLGST/'LGST'/
C---
      ISECLF=10
      ITOK=1
      IF(IUHR(ISECLF).NE.1) ITOK=0
      IF(ITOK.EQ.1) WRITE(6,401)
      IF(ITOK.NE.1) WRITE(6,402)
  401 FORMAT('0TIME OK GOING INTO KALREV.')
  402 FORMAT(1X,' TIME ALMOST OUT GOING INTO KALREV.')
    3 CONTINUE
      IF(ITOK.GT.-20) WRITE(6,403)
  403 FORMAT(1X,' THREE LOOP.')
      ITOK=ITOK-1
      IF(ITOK.LT.0) GO TO 3
      REWIND 3
      REWIND 4
      NRECI=0
      NRECO=0
      LGTIME=-1
    1 CONTINUE
      CALL EVREA1(4,NWORD,JBUF,IRET)
      IF(IRET.EQ.1) GO TO 1000
      IF(IRET.EQ.2) GO TO 2000
      NRECI=NRECI+1
C     IF (NRECI.LT.10) PRINT 2901, (JBUF(II),II=1,10)
 2901 FORMAT (1X,10I10,'     (KALREV F 2901)')
      IF(JBUF(1).NE.NLGST) GO TO 2
      IF(JBUF(6).EQ.LGTIME) GO TO 1
      LGTIME=JBUF(6)
    2 CONTINUE
      CALL KALBNK(3,NWORD,JBUF)
      NRECO=NRECO+1
      GO TO 1
 1000 CONTINUE
      WRITE(6,101) NRECI
  101 FORMAT(' *** READ ERROR ENCOUNTERED AFTER ',I4,' RECORDS.',
     +'     (KALREV F 101)')
      RETURN
 2000 CONTINUE
      WRITE(6,102) NRECI
  102 FORMAT('0NORMAL EOF ON UNIT # 4 AFTER',I6,' RECORDS',
     +'     (KALREV F 102)')
      WRITE(6,103) NRECO
  103 FORMAT ('0',I6,' RECORDS WRITTEN ON UNIT # 2       ',
     +'      (KALREV F 103)')
      PRINT 104
  104 FORMAT (///'0  -----  TESTRUN: ON UNIT # 3')
      RETURN
      END
