C   08/12/80 304211227  MEMBER NAME  JETCAL   (JADEGS)      FORTRAN
C   19/08/80 009041235  MEMBER NAME  JETCAL9  (JADESR)      FORTRAN
      SUBROUTINE JETCAL
C---
C--- **************************************************************
C--- ******************* VERSION FOR NOZAKIS NEW JET CONSTANTS ****
C--- **************************************************************
C---     CREATES CALIBRATED JET CHAMBER BANK.
C---
C---                                    WEDNESDAY, MAY 23, 1979
C---                                    L.H. O'NEILL
C---
C---
C---     SET AMPLITUDES = 0 IF OVERFLOW  P. STEFFEN 12.30 83/04/21
C---
C---     NEW VERSION WITH A TZERO FOR EACH OF THE THREE RINGS.
C---                                   L.H. O'NEILL 19.30 13.08.79
C---   CHANGED 14.9.80 TO ACCOUNT FOR NOZAKIS NEW CONSTANTS
C---                                                  J.OLSSON
C---
C---
      IMPLICIT INTEGER*2 (H)
#include "cdata.for"
#include "cgraph.for"
C------------------------------------------
C  MACRO CJDRCH .... JET CHAMBER CONSTANTS.
C------------------------------------------
      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
     * RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,ZRESOL,ZNORM,ZAL,
     * ZSCAL,DRIDEV,DRICOS,DRISIN,PEDES,TZERO(3),
     * DRIROT(96,2),SINDRI(96,2),COSDRI(96,2),DRIVEL(96,2),T0FIX(3)
C    PREVIOUS MACRO REPLACED WITH EXPLICIT COMMON STATEMENT, TO ACCOUNT
C    FOR INTRODUCTION OF ARRAY T0FIX.  WILL LATER BE INCLUDED IN MACRO
C CORRESPONDING CHANGE MADE IN SUPERV BLOCK DATA     J.OLSSON 14.9.80
C
C--------- END OF MACRO CJDRCH ------------
      COMMON/CALIBR/JPOINT(16)
      DIMENSION HCALIB(2)
      EQUIVALENCE (HCALIB(1),JPOINT(1))
      DATA ZPHS/2440./
      DATA RAMPS/100./
      DATA ICALL/0/
C---
      IF(ICALL.NE.0) GO TO 3
      ICALL=1
      IHEAD=IBLN('HEAD')
      IJETC=IBLN('JETC')
      AC0=0.5*(ZPHS-ZAL)/ZAL
      AC1=0.5*RAMPS*ZPHS/ZAL
    3 CONTINUE
      IPHALF=2*JPOINT(4)
      IPHEA2=2*IDATA(IHEAD)
      NRUN=HDATA(IPHEA2+10)
      IPJET1=IDATA(IJETC)
C---
C---     RENUMBER "JETC 0" TO "JETC 1" AND CREATE "JETC 0".
C---
      NW=IDATA(IPJET1)
      NUMB=IDATA(IPJET1-2)
      CALL BRNM('JETC',NUMB,'JETC',1)
      CALL CCRE(IPJET0,'JETC',0,NW,IERR)
      IF(IERR.NE.0) GO TO 10
      CALL CLOC(IPJET1,'JETC',1)
C---
C---     NOW CALIBRATE "JETC 0".
C---
      IP0=4*IPJET0
      IP1=4*IPJET1
      CALL MVCL(IDATA,IP0,IDATA,IP1,200)
C---
C---     COPY BANK DESCRIPTOR, CELL POINTERS AND LIST OF WIRES WITH
C---     MORE THAN 8 HITS. THE LATTER LIST IS AT THE END OF THE BANK
C---
      NEND=2*(HDATA(2*IPJET0+100)-HDATA(2*IPJET0+99))
      IP2=IP0+4*NW-NEND
      IP3=IP1+4*NW-NEND
      IF(NEND.GT.0) CALL MVCL(IDATA,IP2,IDATA,IP3,NEND)
C---
C---     ADD 100 TO FIRST I*2 BANK DESCRIPTOR WORD FOR CALIBRATED BANK.
C---
      HDATA(2*IPJET0+1)=HDATA(2*IPJET0+1)+200
      NHITS=(HDATA(2*IPJET0+99)-HDATA(2*IPJET0+3))/4
      IF(NHITS.LT.1) RETURN
      J=2*IPJET1+100
      K=2*IPJET0+100
      KMAX=K+HDATA(K-1)
    2 CONTINUE
      J=J+1
      K=K+1
      IF(K.GE.KMAX) GO TO 1
      HDATA(K)=HDATA(J)
      IWIRE=HDATA(J)
      J=J+1
      K=K+1
      IA1=HDATA(J)
      IF(IA1.LT.0) IA1=0
      IF(IA1.GE.4095) IA1=0
      IA1=ISHFTL(IA1,3)
      IA2=HDATA(J+1)
      IF(IA2.LT.0) IA2=0
      IF(IA2.GE.4095) IA2=0
      IA2=ISHFTL(IA2,3)
C     IHITN=LAND(IWIRE,7)
      IWIRE=ISHFTR(IWIRE,3)
C     IHITN=ISHFTL(IHITN,2)
C     IPLOC=IPHALF+34*IWIRE
      IPLOC=IPHALF+6*IWIRE
      ITZERO=HCALIB(IPLOC+1)
      SF=AC0+AC1/HCALIB(IPLOC+2)
C     IPLOC=IPLOC+IHITN
      IPEDL1=HCALIB(IPLOC+3)
      IGAIN1=HCALIB(IPLOC+4)
      IPEDL2=HCALIB(IPLOC+5)
      IGAIN2=HCALIB(IPLOC+6)
C---
C---     THE 512 (2**9) ADDED BELOW CAUSES THE SUBSEQUENT SHIFT RIGHT
C---     BY 10 BITS TO DO A ROUND OFF RATHER THAN A TRUNCATION.
C---
      IF(IA1.GT.0) IA1=IGAIN1*(IA1-IPEDL1)+512
      IF(IA1.LT.0) IA1=0
      IA1=ISHFTR(IA1,10)
      IF(IA2.GT.0) IA2=IGAIN2*(IA2-IPEDL2)+512
      IF(IA2.LT.0) IA2=0
      IA2=ISHFTR(IA2,10)
C---
C---     COMPUTE AMPLITUDE SLEWING CORRECTION AT THIS POINT.
C---
C---    NEW SLEWING CORRECTION INTRODUCED WITH NEW CONSTANTS,
C---    PARABOLIC CORRECTION, DIFFERENT FOR SMALL AND BIG AMPLITUDES;
C---                                              J.OLSSON  14.9.80
C---
      IAMCOR=0
      IAM=IA1
      IF(IA2.GT.IA1) IAM=IA2
C     IF(IAM.GT.2400) GO TO 200
C     TAMCOR=-66.2784+0.027616*IAM
C     IAMCOR=TAMCOR-0.5
C 200 CONTINUE
      IF(NRUN.GE.6185) GO TO 203
C -------- NEW   14.9.80
      IF(IAM.GT.2000) GO TO 200
      TAMCOR = -64.*1.494 + 7.872E-03*IAM*8. - 1.157E-05*IAM*IAM
      GO TO 201
200   IF(IAM.GT.4000) GO TO 202
      TAMCOR = -64.*0.8207 + 2.926E-03*IAM*8. - 2.561E-06*IAM*IAM
201   IAMCOR = TAMCOR - 0.5
202   CONTINUE
      GO TO 204
C -------- END NEW   14.9.80
C -------- NEW   25.3.81
203   CONTINUE
      IF(IAM.GT.1800) GO TO 205
      TAMCOR = -64.*1.811 + 1.112E-02*IAM*8. - 2.155E-05*IAM*IAM
      GO TO 206
205   IF(IAM.GT.5600) GO TO 204
      TAMCOR = -64.*0.8430 + 2.340E-03*IAM*8. - 1.623E-06*IAM*IAM
206   IAMCOR = TAMCOR - 0.5
C -------- END NEW   25.3.81
204   CONTINUE
      AX=SF*(IA2-IA1)
      IF(AX.GT.0.) AX=AX+0.5
      IF(AX.LT.0.) AX=AX-0.5
      IS=AX
      IF(IA1.GT.0) IA1=IA1-IS
      IF(IA1.LT.    0) IA1=0
      IF(IA1.GT.32767) IA1=32767
      IF(IA2.GT.0) IA2=IA2+IS
      IF(IA2.LT.    0) IA2=0
      IF(IA2.GT.32767) IA2=32767
      HDATA(K  )=IA1
      HDATA(K+1)=IA2
      J=J+2
      K=K+2
      IDTIME=HDATA(J)
      IF(IDTIME.LT.0) IDTIME=0
      IF(IDTIME.GT.255) IDTIME=255
      IDTIME=ISHFTL(IDTIME,6)-ITZERO+IAMCOR
      KLOK=1
      IF(IWIRE.GE.384) KLOK=2
      IF(IWIRE.GE.768) KLOK=3
C -------- NEW   14.9.80
      TPED=64.*(TZERO(KLOK) + T0FIX(KLOK)) + 10000.5
C -------- END NEW   14.9.80
C     TPED=64.*TZERO(KLOK)+10000.5
      IPED=TPED
      IPED=IPED-10000
C---  IF(IDTIME.LT.IPED) IDTIME=IPED
      HDATA(K)=IDTIME-IPED
      GO TO 2
    1 CONTINUE
      RETURN
   10 CONTINUE
      WRITE(JUSCRN,101) IERR
  101 FORMAT(' ERROR RETURN',I4,' FROM CCRE.')
      RETURN
      END
