C   17/03/79 407311224  MEMBER NAME  EVPK     (JADESR)      FORTRAN
C
C  LATEST CHANGE: 17/10/79 11.05 (BANK NAME TABLE WAS CHANGED.)
C  LATEST CHANGE: 31/07/84 12.28 (BANK NAME TABLE WAS CHANGED.)
C
      SUBROUTINE EVPK
      IMPLICIT INTEGER*2 (H)
      INTEGER*2 IARR(20004),IBUFF
      INTEGER*4 BUFFL,DALEN,LUN
      COMMON/MNF/IRUN,IREC,NEV,ISTAT,IFLAG,NWPR,BUFFL,DALEN,
     C   IND,ISPEC,LUN
      COMMON/BUFFER/IBUFF(2048)
      COMMON/CDATA/LENG,ID1(2),ID(10000)
      DIMENSION HX(3200),HD(20000),HB(20)
      DIMENSION IX(1557)
      DIMENSION JD(52),JD2(52)
      REAL*8 DATE(2)
      EQUIVALENCE (ID(1),HD(1),IARR(5)),(IX(1),HX(1))
      DATA IHD/'HIDD'/,JD2(1)/0/,HSTRC/0/
C
      DIMENSION MA(129),MB1(32),MB2(32),MB3(32),MB4(32)
      EQUIVALENCE (MA(1),MB1(1)),(MA(33),MB2(1))
      EQUIVALENCE (MA(65),MB3(1)),(MA(97),MB4(1))
      DATA MB1/'HEAD','LATC','TRG1','TRG2',
     D         'TRG3','ATST','ATBP','ATOF',
     D         'ALGL','ATAG','TAGC','JETC',
     D         'MUEV','SCAL','MPRS','N50S',
     D         'BK17','BK18','ZETC','BPCH','BK21','BK22',
     D         'BK23','BK24','BK25','BK26','BK27','BK28',
     D         'BK29','BK30','BK31','BK32'/
      DATA MB2/'JETV','FADC','BK35','BK36',
     D         'BK37','BK38','BK39','BK40','BK41','BK42',
     D         'BK43','BK44','BK45','BK46','BK47','BK48',
     D         'BK49','BK50','BK51','BK52','BK53','BK54',
     D         'BK55','BK56','BK57','BK58','BK59','BK60',
     D         'BK61','BK62','BK63','BK64'/
      DATA MB3/'C065','C066','C067','C068',
     D         'C069','C070','C071','C072','C073','C074',
     D         'C075','C076','C077','C078','C079','C080',
     D         'C081','C082','C083','C084','C085','C086',
     D         'C087','C088','C089','C090','C091','C092',
     D         'C093','C094','C095','C096'/
      DATA MB4/'C097','C098','C099','C100',
     D         'C101','C102','C103','C104','C105',
     D         'C106','C107','C108','C109','C110',
     D         'C111','C112','C113','C114','C115',
     D         'C116','C117','C118','C119','C120',
     D         'C121','C122','C123','C124','C125',
     D         'C126','C127','C128'/
      DATA MA(129)/'WRNG'/
C
      DATA IX/1557*0/
      DATA NTOT,NTOLD,NBLK,NV,NS/5*0/
   14 FORMAT(' ',I5,21I6)
   18 FORMAT('0',4X,20I6)
   19 FORMAT(' ',I11,20I6)
   21 FORMAT('0',I6,' BLOCKS,  ',I6,' EVENTS')
   30 FORMAT('0','ERROR IN COUNTING, TYPE 400 , ',16I6)
   40 FORMAT('0','WRONG EVENT STRUCTURE AT RUN # ',I6,', BLOCK #',
     F I6,', EVENT # ',I6,', WITH LENG, HB2, HSTRC = ',3I6)
      N=0
      JD2(1)=0
      IX(1)=IHD
      IX(3)=0
  200 CONTINUE
      CALL EVENT
      IF(ISTAT.EQ.4) GO TO 1000
      IF(ISTAT.NE.1) GO TO 200
      LENG=(IARR(2)-3)/2
      NEV=NEV+1
C
C    PUT IN BANK NAME AND JD2(I),WHERE THE LOCATIONS OF THE LAST WORD
C    OF EACH BANK IN I*4 WORDS ARE STORED
C
      HB1=1
      HB2=2
      DO 210 I=1,50
      IF(HD(HB2-1).NE.32767) GO TO 1400
      HDHB2=HD(HB2)
      IF(HDHB2.GE.129) HDHB2=129
      IF(HDHB2.LE.0) HDHB2=129
      ID(HB1)=MA(HDHB2)
      HB2=HB2+2*HD(HB2+6)+8
      J=I+1
      HB1=HB2/2
      JD2(J)=HB1-1
      IF(JD2(J).GE.LENG) GO TO 220
  210 CONTINUE
      J=51
  220 N2=J
C
      CALL LISTRN(2)
C
      NV=NV+1
      IX(NTOT+1)=IHD
      IX(NTOT+2)=NEV
      IX(NTOT+3)=0
      NTOLD=NTOT
      NTOT=NTOT+LENG+5
      IF(NTOT.GE.1538) GO TO 300
      NTOLD1=NTOLD+5
      IX(NTOLD+4)=LENG+1
      IX(NTOLD1)=0
      IF(NS.GE.1) IX(NTOLD1)=3
      CALL UCOPY2(ID(1),IX(NTOLD1+1),LENG)
      GO TO 200
  300 CONTINUE
      IF(NTOT.GE.1558) GO TO 400
      NTOLD1=NTOLD+5
      IX(NTOLD+4)=LENG+1
      IX(NTOLD1)=0
      IF(NS.GE.1) IX(NTOLD1)=3
      CALL UCOPY2(ID(1),IX(NTOLD1+1),LENG)
      WRITE(2) NTOT,IX
      NBLK=NBLK+1
      CALL UZERO(IX,1527,1557)
      NTOT=0
      NV=0
      GO TO 200
  400 CONTINUE
      NW=0
      K7=0
      K8=0
  410 CONTINUE
      K3=0
      K4=NTOT
      CALL UCOPIV(JD2,JD,N2)
C--- SUPPOSE XX IS THE LAST COMPLETE BANK OF THE BLOCK AND YY IS THE
C--- BANK NEXT TO XX, I.E.,YY IS AN INCOMPLETE BANK,THEN K1 IS THE
C--- LOCATION OF THE LAST WORD IN BANK XX WITH RESPECTIVE TO THE
C--- BEGINNING OF THE EVENT, THE HIDD HEADER IS NOT INCLUDED IN THE
C--- COUNTING.  K2 IS THE LOCATION OF THE SAME WORD WITH RESPECT TO
C--- THE BEGINNING OF THE BLOCK, WITH THE 5 WORDS HIDD HEADER COUNTED,
C--- SO, IF THE EVENT IS INSIDE A BLOCK,THEN K1 LT K2.IF THE EVENT
C--- START FROM THE LAST BLOCK, THEN K1 GT K2
      DO 430 J=1,N2
      K1=JD(J)
      K2=K1+NTOLD-NW+5
      K3=K3+8
      K5=J
      IF(K2.GE.1548.AND.K2.LE.1557) GO TO 500
      IF(K2.LE.1547.AND.K4.GE.1558) GO TO 440
      K4=K2
  430 CONTINUE
      WRITE(6,30) NEV,NV,LENG,NS,NTOT,NTOLD,K1,K2,K3,K4,K5
      GO TO 2000
  440 CONTINUE
      JJ=1552-NTOLD-K8
      NTOLD1=NTOLD+5
      IX(NTOLD+4)=1553-NTOLD
      IX(NTOLD1)=1
      IF(NS.GE.1) IX(NTOLD1)=2
      NTOLD2=NTOLD1+K8
      CALL UCOPY2(ID(K7+1),IX(NTOLD2+1),JJ)
      K6=K2
      IF(K2.LE.5) K6=5
      IX(K6+4)=1553-K6
      NTOT1=1557
      WRITE(2) NTOT1,IX
      NBLK=NBLK+1
      CALL UZERO(IX,1527,1557)
      NS=1
C**    AN EVENT WAS SPANNED, SO NS=1
      NTOT1=NTOT-1557
      NTOT=NTOT1+9
      IX(1)=IHD
      IX(2)=NEV
      IX(3)=0
      IX(6)=ID(K1+1)
      IX(7)=ID(K1+2)
      IX(8)=ID(K1+3)
      IX(9)=ID(K1+4)+K2-1553
      NV=1
      IF(NTOT.GE.1558) GO TO 490
      IF(NTOT.GE.1538) GO TO 480
      CALL UCOPY2(ID(JJ+K7+1),IX(10),NTOT1)
      IX(4)=NTOT-4
      IX(5)=3
      NS=0
C**    END OF SPANNING
C**    WE PUT IN ONE MORE BANK HEADER AT THE NEW BLOCK
C**    IN ADDITION TO THE HIDD HEADER
      GO TO 200
  480 CONTINUE
      IX(4)=NTOT-4
      IX(5)=3
      CALL UCOPY2(ID(JJ+K7+1),IX(10),NTOT1)
      WRITE(2) NTOT,IX
      NBLK=NBLK+1
      CALL UZERO(IX,1527,1557)
      NTOT=0
      NS=0
      GO TO 200
  490 CONTINUE
      NW=NW+1557-NTOLD-9
      K7=K7+JJ
      K8=4
      NTOLD=0
      GO TO 410
  500 CONTINUE
      NTOLD1=NTOLD+5
      NTOLD4=NTOLD+4
      IX(NTOLD4)=K1+1
      IX(NTOLD1)=1
      IF(NS.GE.1) IX(NTOLD1)=2
      NTOLD2=NTOLD1+K8
      K9=K1-K7
      IF(NS.GE.1) IX(NTOLD4)=K9+K8+1
      CALL UCOPY2(ID(K7+1),IX(NTOLD2+1),K9)
      WRITE(2) K2,IX
      NBLK=NBLK+1
      CALL UZERO(IX,1527,1557)
      NS=1
C**    AN EVENT WAS SPANNED, SO NS=1
      NTOT1=NTOT-K2
      NTOT=NTOT1+5
      NV=1
      IX(1)=IHD
      IX(2)=NEV
      IX(3)=0
      IF(NTOT.GE.1558) GO TO 580
      IF(NTOT.GE.1538) GO TO 560
      CALL UCOPY2(ID(K1+1),IX(6),NTOT1)
      IX(4)=NTOT-4
      IX(5)=3
      NS=0
      GO TO 200
  560 CONTINUE
      IX(4)=NTOT-4
      IX(5)=3
      CALL UCOPY2(ID(K1+1),IX(6),NTOT1)
      WRITE(2) NTOT,IX
      NS=0
      NTOT=0
      NBLK=NBLK+1
      CALL UZERO(IX,1527,1557)
      GO TO 200
  580 CONTINUE
      NW=NW+K2-NTOLD-5
      NTOLD=0
      K7=K7+K1
      K8=0
      GO TO 410
 1000 IF(NTOT.EQ.0) GO TO 1300
      NT1=NTOT+1
      IF(NT1.GE.1558) GO TO 1100
      CALL UZERO(IX,NT1,1557)
 1100 CONTINUE
      WRITE(2) NTOT,IX
      NBLK=NBLK+1
      WRITE(6,21) NBLK,NEV
C     WRITE(6,18) HB
C     WRITE(6,18)
C     IJK=NTOT/10+1
C     DO 1200 J=1,IJK
C     IJ=20*J
C     IK=IJ-19
C1200 WRITE(6,14) IK,(HX(K),K=IK,IJ),IJ
C     IF(NTOT.GE.1551) WRITE(6,19) (HX(K),K=3101,3114)
      NTOT=0
 1300 NS=0
      RETURN
C--- WRONG EVENT STRUCTURE
 1400 HSTRC=HSTRC+1
      WRITE(6,40) IBUFF(5),IBUFF(3),NEV,LENG,HB2,HSTRC
      GO TO 200
 2000 RETURN
      END
