C   19/02/84 409061158  MEMBER NAME  BANKPR2  (S)           FORTRAN
C
C-----------------------------------------------------------------------
      SUBROUTINE BANKPR 
C-----------------------------------------------------------------------
C
C   AUTHOR:   L. O'NEILL     ?     :  PRINT BOS BANK NAMES OR CONTENTS.
C
C        MOD: J. OLSSON   15/11/83 :
C        MOD: C. BOWDERY  14/02/84 :  RESOLVE PROBLEM WITH DELETED BANKS
C   LAST MOD: C. BOWDERY  14/02/84 :  NAMES PRINTED BY S/R EVBKPR
C
C-----------------------------------------------------------------------
C
      IMPLICIT INTEGER*2 (H)
C PMF 03.11.98 
      LOGICAL TBIT
C
      REAL*8 DATE,TIME
C
#include "cgraph.for"
#include "cdata.for"
C
      COMMON / CWORK  / HDUM(8000),
     +                  HADC(2,42),HTDC(2,42),HTDC1(2,42),HADCF(2,16),
     +                  HTDCF(2,16),HTSPAR(16)
      COMMON / CWORK1 / HWORK(70),DATE,TIME
      COMMON / CHEADR / HEAD(108)
C
      DIMENSION HDSPL(68),HSYM(10),HDATSV(22),HTX(6),HTM1(4),HTM2(4)
      DIMENSION NAMES(20),HSX(13,16),HELP(2)
      DIMENSION HSY(13,16)
C
      EQUIVALENCE (IZWORD,HELP(1))
      EQUIVALENCE (HWORK(1),NAME)
      EQUIVALENCE (HWORK(3),HDSPL(1))
      EQUIVALENCE (HDATSV(1),IDATSV(1)),(DATE,HTM1(1)),(TIME,HTM2(1))
C
      DATA NAMES/'JETC','PATR','TAGC','JHTL','ZETC','GVTX','DEDX',
     $ 'ZVTX','LGCL','TOFR','TPEV','TPTR','ATOF','TPVX','VECT','TRIG',
     $ 'N50S','MPRS','BK17','ZTRG'/
C
      DATA HSYM /'0 ','1 ','2 ','3 ','4 ','5 ','6 ','7 ','8 ','9 '/
      DATA HBLANK/'  '/,HMINUS/'- '/, NNAMES /20/,MASKMH/Z001F/
      DATA HTX /'DS','N ','DA','TE','TI','ME'/
C
      DATA HSX/
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'*M','UL','TI','HA','DR','ON','IC',' E','VE','NT','**','  ','  ',
     $'*N','ON','-B','AR','RE','L ','BH','AB','HA',' E','VE','NT','**',
     $'*B','AR','RE','L ','BH','AB','HA',' E','VE','NT','**','  ','  ',
     $'*2','-P','HO','TO','N ','EV','EN','T*','* ','  ','  ','  ','  ',
     $'*M','UO','N-','PA','IR',' E','VE','NT','**','  ','  ','  ','  ',
     $'*B','EA','M-','BE','AM',' E','VE','NT','**','  ','  ','  ','  ',
     $'*C','OS','MI','C ','EV','EN','T*','* ','  ','  ','  ','  ','  ',
     $'*B','EA','M-','GA','S ','EV','EN','T*','* ','  ','  ','  ','  ',
     $'*H','AL','O ','EV','EN','T*','* ','  ','  ','  ','  ','  ','  ',
     $'*L','UM','I ','EV','EN','T*','* ','  ','  ','  ','  ','  ','  ',
     $'*U','NI','DE','NT','IF','IE','D ','EV','EN','T*','* ','  ','  ',
     $'*R','EJ','EC','TE','D ','EV','EN','T*','* ','  ','  ','  ','  '/
C
      DATA HSY/
     $'UN','EX','PE','CT','ED',' I','NT','ER','RU','PT',' N','-3','  ',
     $'UN','EX','PE','CT','ED',' I','NT','ER','RU','PT',' N','-2','  ',
     $'NO','N ','IN','CR','EA','SI','NG',' W','IR','E-','NU','MB','ER',
     $'IL','LE','GA','L ','HI','T ','CO','UN','TE','R ','  ','  ','  ',
     $'NE','GA','TI','VE',' D','AT','A ','FO','UN','D ','  ','  ','  ',
     $'JE','TC',' B','AN','K ','LO','NG','ER',' T','HA','N ','40','00',
     $'WI','RE',' N','UM','BE','R ','GR','EA','TE','R ','15','36','  ',
     $'NO',' H','IT','S ','IN',' R','IN','G2','  ','  ','  ','  ','  ',
     $'LA','ST',' C','EL','L ','IN',' R','IN','G ','IN','CO','MP','L.',
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'T2','  ','RE','JE','CT','  ','  ','  ','  ','  ','  ','  ','  ',
     $'Z-','VE','RT','EX',' R','EJ','EC','T ','  ','  ','  ','  ','  ',
     $'  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ','  ',
     $'AC','TU','AL','LY',' R','EJ','EC','TE','D ','BY',' N','10','  '/
*** PMF 17/11/99: add variables needed for emulation of DESYLIB routine 'CORE'  
      CHARACTER cHWORK*140,cHDSPL*136
      EQUIVALENCE (cHWORK,HWORK(1)),(cHDSPL,HDSPL(1))
*** PMF(end)
C
C------------------  C O D E  ------------------------------------------
C
      NN = ACMD
      IF( NN .GE. 0 ) GO TO 1803
C
C                            NEGATIVE INDEX --> PRINT BOS BANK NAMES
C
      CALL EVBKPR(ICODE)
      IF( ICODE .EQ. 0 ) RETURN
      CALL TRMOUT(80,'ERROR IN BMRT (CURRENT LIST), CALLED IN BANKPR^')
      RETURN
C
1803  CALL TRMOUT(80,' * * PLEASE ENTER NAME OF DESIRED BANK.^')
      CALL TRMIN(4,NAMEB)
      IBANK=IBLN(NAMEB)
      IPBANK=IDATA(IBANK)
200   LIM1=IPBANK-2
210   IF(LIM1.GE.1) GO TO 3
35    CALL TRMOUT(80,'THE BANK IS EMPTY OR DOES NOT EXIST.^')
      RETURN
C** CHECK IF MORE THAN ONE BANK WITH SAME NAME; IF SO, REQUEST NUMBER.
3     IF(IDATA(LIM1+1).EQ.0) GO TO 300
      IF(NAMEB.EQ.NAMES(15)) GO TO 300
      CALL TRMOUT(80,'FOLLOWING BOS BANK NRS ARE PRESENT:^')
      LM1 = LIM1
3332  CALL DIAGIN('                    ',1,IDATA(LM1),N,N,N,N,N)
      IF(IDATA(LM1+1).EQ.0) GO TO 3333
      LM1 = IDATA(LM1+1)-2
      GO TO 3332
3333  CALL TRMOUT(80,'PLEASE ENTER DESIRED BOS BANK NUMBER.^')
      NBOS = TERNUM(DUMMY)
33    IF(NBOS.EQ.IDATA(LIM1)) GO TO 300
      IF(IDATA(LIM1+1).NE.0) GO TO 34
      GO TO 35
34    LIM1 = IDATA(LIM1+1) - 2
      GO TO 33
300   CALL ERASE
      IRETUR = 1
C********************** WRITE CAPTION
      CALL HOME
      CALL CHRSIZ(4)
      HWORK(1) = HTX(1)
      HWORK(2) = HTX(2)
      HWORK(3) = HBLANK
      DO 4988  I = 1,22
4988  HWORK(I+3) = HDATSV(I)
      CALL EOUTST(50,HWORK)
      KCNT=0
      IHEAD=IBLN('HEAD')
      IPHEAD=IDATA(IHEAD)
      IHHEAD=2*IPHEAD
      DO 5001 III=1,3
      IF(III.EQ.1) NUMCAP=HDATA(IHHEAD+10)
      IF(III.EQ.2) NUMCAP=HDATA(IHHEAD+11)
      IF(III.EQ.3) NUMCAP=ICREC
      IF(NUMCAP.LT.0) KCNT=KCNT+1
      IF(NUMCAP.LT.0) HWORK(KCNT)=HMINUS
      NUMCAP=IABS(NUMCAP)
      NDIG=1
      ACAP=NUMCAP
      IF(NUMCAP.GT.0) NDIG=1+ALOG10(ACAP+0.001)
      IF(NDIG.GT.8) NDIG=8
      DO 5002 JJJ=1,NDIG
      KKK=KCNT+NDIG-JJJ+1
      NTEN=NUMCAP/10
      IDIG=NUMCAP-10*NTEN
      HWORK(KKK)=HSYM(IDIG+1)
      NUMCAP=NTEN
 5002 CONTINUE
      KCNT=KCNT+NDIG
      IF(III.LT.3) KCNT=KCNT+1
      IF(III.LT.3) HWORK(KCNT)=HBLANK
 5001 CONTINUE
      KCNT = 2*KCNT
      CALL NEWLIN
      CALL EOUTST(KCNT,HWORK)
5118  CONTINUE
C WRITE DATE AND TIME
      CALL DAY(DATE,TIME)
      HWORK(1) = HTX(3)
      HWORK(2) = HTX(4)
      HWORK(3) = HBLANK
      DO 4987  I = 1,4
4987  HWORK(I+3) = HTM1(I)
      CALL NEWLIN
      CALL EOUTST(14,HWORK)
      HWORK(1) = HTX(5)
      HWORK(2) = HTX(6)
      HWORK(3) = HBLANK
      DO 4986  I = 1,4
4986  HWORK(I+3) = HTM2(I)
      CALL NEWLIN
      CALL EOUTST(14,HWORK)
      CALL NEWLIN
      CALL CHRSIZ(3)
      CALL NEWLIN
C****************************** WRITE BANK HEADER
      LIM2=LIM1+3
      LIMX = LIM2-1
      LIMHX = 2*LIMX
      NAME=IDATA(LIM1-1)
      CALL CORE(HDSPL,76)
      WRITE(cHDSPL,9001)
     +     (IDATA(LHO),LHO=LIM1,LIMX),(HDATA(LIMHX+J),J=1,2)! PMF 17/11/99: UNIT=10 -> UNIT=cHDSPL
 9001 FORMAT(3I10,2I10)
      CALL EOUTST(80,HWORK)
      CALL NEWLIN
C     CALL PROMPT
      CALL SEELOC(IXT,IYT)
      XS = IXT
      YS = IYT
      CALL CHRSIZ(4)
      CALL CSIZE(IX,IXT)
      SIZE = IXT*.8
      DEL = 1.7*SIZE
C****************************** WRITE BANK CONTENT
      NWO = IDATA(LIM2-1) - 1
      LENGB=2*NWO
      NCYCLE=1+(LENGB-1)/20
      INNAM = 0
      DO 1473  INN = 1,NNAMES
      IF(NAMEB.NE.NAMES(INN)) GO TO 1473
      INNAM = INN
      GO TO 1474
1473  CONTINUE
      GO TO 1092
1474  GO TO (2001,877,1092,1092,5177,1277,1377,1577,1677,1977,2077,2177,
     $ 3177,4177,277,1092,3235,1940,2240,2550), INNAM
C-------------- NORMAL PRINT OF BANKS, INTEGER*2 OR Z4 FORMAT
1092  CONTINUE
      DO 9010 LHO=1,NCYCLE
9006  YS = YS - DEL
      IF(YS.GT.50.) GO TO 9012
      IRETUR = 4
      GO TO 9965
9012  LIML=2*LIM2+20*(LHO-1)+1
      LIMU = LIML + 19
      IF(LIMU.GT.(2*LIM2+LENGB)) LIMU=2*LIM2+LENGB
      ILIM = LIMU - LIML + 1
      IF(ILIM.LE.0) GO TO 9020
      DO 9025  I = 1,ILIM
      LLO = LIML + I - 1
9025  HWORK(I+100) = HDATA(LLO)
      IILIM = 6*ILIM + 1
      CALL CORE(HWORK,IILIM)
      IF(NAMEB.NE.NAMES(3).AND.NAMEB.NE.NAMES(4).AND.NAMEB.NE.NAMES(16))
     $ WRITE(cHWORK,9011) (HWORK(LLO+100),LLO=1,ILIM) ! PMF 17/11/99: JUSCRN changed to cHWORK
      IF(NAMEB.EQ.NAMES(3).OR.NAMEB.EQ.NAMES(4).OR.NAMEB.EQ.NAMES(16))
     $ WRITE(cHWORK,9111) (HWORK(LLO+100),LLO=1,ILIM) ! PMF 17/11/99: JUSCRN changed to cHWORK
 9011 FORMAT(' ',20I6)
 9111 FORMAT(' ',20(Z4,2X))
      CALL SYSSYM(XS,YS,SIZE,HWORK,IILIM,0.)
 9010 CONTINUE
      GO TO 9020
C____________________________ SPECIAL FORMAT FOR JETC BANK
2001  LENGB = LENGB + 2
      NCYCLE=1+(LENGB-1)/20
      LENGB = LENGB - 2
      DO 8010 LHO=1,NCYCLE
8006  YS = YS - DEL
      IF(YS.GT.50.) GO TO 8012
      IRETUR = 5
      GO TO 9965
8012  LIML=2*LIM2+20*(LHO-1)+1
      IF(LHO.GT.5) LIML = LIML - 2
      LIMU = LIML + 19
      IF(LHO.EQ.5) LIMU = LIMU - 2
      IF(LIMU.GT.(2*LIM2+LENGB)) LIMU=2*LIM2+LENGB
      ILIM = LIMU - LIML + 1
      IF(ILIM.LE.0) GO TO 9020
      DO 8025  I = 1,ILIM
      LLO = LIML + I - 1
8025  HWORK(I+100) = HDATA(LLO)
      IF(LHO.LE.5) GO TO 8026
      DO 8027  I = 1,ILIM,4
      IX = HWORK(I+100)
      IX = ISHFTR(IX,3)
8027  HWORK(I+100) = IX
8026  IILIM = 6*ILIM + 1
      CALL CORE(HWORK,IILIM)
      WRITE(cHWORK,9011) (HWORK(LLO+100),LLO=1,ILIM) ! PMF 17/11/99: JUSCRN changed to cHWORK
      CALL SYSSYM(XS,YS,SIZE,HWORK,IILIM,0.)
 8010 CONTINUE
      GO TO 9020
C--------------- SPECIAL FORMAT FOR ATOF BANK
3177  IPTOF = LIM2-1
      CALL AGRPR(IPTOF,&3173)
      GO TO 3174
3173  WRITE(6,3175)
3175  FORMAT(' ATFUGR ERROR, WRONG BANK DESCRIPTOR...' )
      RETURN
3174  CALL CORE(HWORK,107)
      WRITE(cHWORK,3181) ! PMF 17/11/99: JUSCRN changed to cHWORK
3181  FORMAT(' NR   ADC(L)  ADC(R)   TDC(L)  TDC(R)   TDC1(L)  TDC1(R)
     $ ADCF(L)  ADCF(R)   TDCF(L)  TDCF(R)   TDC(SPARE)')
      CALL SYSSYM(XS,YS,SIZE,HWORK,107,0.)
      YS = YS - .9*DEL
      DO 3178  I = 1,42
      IF(I.GT.16) GO TO 3179
      CALL CORE(HWORK,106)
      WRITE(cHWORK,3185) I,(HADC(J,I),J=1,2),(HTDC(J,I),J=1,2), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $(HTDC1(J,I),J=1,2),(HADCF(J,I),J=1,2),(HTDCF(J,I),J=1,2),HTSPAR(I)
3185  FORMAT(' ',I2,2X,I6,2X,I6,3X,I6,2X,I6,3(3X,I7,2X,I7),3X,I10)
      CALL SYSSYM(XS,YS,SIZE,HWORK,106,0.)
      GO TO 3186
3179  CALL CORE(HWORK,55)
      WRITE(cHWORK,3187) I,(HADC(J,I),J=1,2),(HTDC(J,I),J=1,2), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ (HTDC1(J,I),J=1,2)
3187  FORMAT(' ',I2,2X,I6,2X,I6,3X,I6,2X,I6,3X,I7,2X,I7)
      CALL SYSSYM(XS,YS,SIZE,HWORK,55,0.)
3186  YS = YS - .9*DEL
      IF(MOD(I,10).EQ.0) YS = YS -.2*DEL
3178  CONTINUE
      GO TO 9020
C--------------- SPECIAL FORMAT FOR VECT BANK
C-  FIRST VECT 0, THEN VECT 1 IF IT EXISTS
C-
277   IVPS = 0
      LIM2 = LIM2 - 1
2782  LO = IDATA(LIM2+1)
      LTR = IDATA(LIM2+2)
      NTR = IDATA(LIM2+4)
      IPO = LIM2 + LO
      CALL CORE(HWORK,106)
      WRITE(cHWORK,278) (IDATA(LIM2+II),II=1,LO) ! PMF 17/11/99: JUSCRN changed to cHWORK
278   FORMAT('  ',6I8,2F8.4,5I8)
      LOO = LO*8+2
      CALL SYSSYM(XS,YS,SIZE,HWORK,LOO,0.)
      LO1 = MIN0(12,LO)
      IF(LO1.LT.7) GO TO 2791
      YS = YS - DEL
      CALL CORE(HWORK,124)
      WRITE(cHWORK,178) (ADATA(LIM2+II),II=7,LO1) ! PMF 17/11/99: JUSCRN changed to cHWORK
178   FORMAT(' HEADER WORDS 7-.. ',6E14.6)
      LOO = (LO1-6)*14+19
      CALL SYSSYM(XS,YS,SIZE,HWORK,LOO,0.)
2791  ICNT = 0
279   ICNT = ICNT + 1
      IF(ICNT.GT.NTR.AND.IVPS.EQ.1) GO TO 9020
      IF(ICNT.GT.NTR.AND.IVPS.EQ.0) GO TO 2781
275   YS = YS - DEL
      IF(YS.GT.50.) GO TO 276
      IRETUR = 3
      GO TO 9965
276   IPP = IPO + (ICNT-1)*LTR
      IF(LTR.EQ.10) CALL CORE(HWORK,95)
      IF(LTR.EQ.12) CALL CORE(HWORK,115)
      IF(LTR.EQ.10)
     1  WRITE(cHWORK,274) (ADATA(IPP+I),I=1,5),(IDATA(IPP+I),I=6,7), ! PMF 17/11/99: JUSCRN changed to cHWORK
     2 (ADATA(IPP+I),I=8,10)
274   FORMAT(' ',4F10.4,2X,F10.6,2X,2I4,2X,3F10.3)
      IF(LTR.EQ.12)
     1  WRITE(cHWORK,284) (ADATA(IPP+I),I=1,5),(IDATA(IPP+I),I=6,7), ! PMF 17/11/99: JUSCRN changed to cHWORK
     2 (ADATA(IPP+I),I=8,10),HDATA(2*IPP+21),HDATA(2*IPP+22),
     3  ADATA(IPP+12)
284   FORMAT(' ',4F10.4,2X,F10.6,2X,2I4,2X,3F10.3,2I5,F10.2)
      IF(LTR.EQ.10) CALL SYSSYM(XS,YS,SIZE,HWORK,95,0.)
      IF(LTR.EQ.12) CALL SYSSYM(XS,YS,SIZE,HWORK,115,0.)
      GO TO 279
2781  CONTINUE
      LIM2 = IDATA(LIM2-1)
      IF(LIM2.LT.1) GO TO 9020
      IVPS = 1
C* WRITE BANK HEADER FOR VECT 1
      CALL NEWLIN
      CALL NEWLIN
      LIM1=LIM2-2
      LIMX = LIM2
      LIMHX = 2*LIMX
      NAME=IDATA(LIM2-3)
      CALL CORE(HDSPL,76)
      WRITE(cHDSPL,9001)
     +   (IDATA(LHO),LHO=LIM1,LIMX),(HDATA(LIMHX+J),J=1,2) ! PMF 17/11/99: UNIT=10 -> UNIT=cHDSPL
      CALL EOUTST(80,HWORK)
      CALL NEWLIN
      CALL SEELOC(IXT,IYT)
      XS = IXT
      YS = IYT
      CALL CHRSIZ(4)
      CALL CSIZE(IX,IXT)
      GO TO 2782
C--------------- SPECIAL FORMAT FOR TPVX BANK
4177  LIM2 = LIM2 - 1
      LIMLIM = 2*LIM2
      CALL CORE(HWORK,13)
      WRITE(cHWORK,4178) HDATA(LIMLIM+1),HDATA(LIMLIM+2) ! PMF 17/11/99: JUSCRN changed to cHWORK
4178  FORMAT(' ',I4,I8)
      CALL SYSSYM(XS,YS,SIZE,HWORK,13,0.)
      YS = YS - DEL
      CALL CORE(HWORK,108)
      WRITE(cHWORK,4179) (ADATA(LIM2+1+I),I=1,7),IDATA(LIM2+9), ! PMF 17/11/99: JUSCRN changed to cHWORK
     1 ADATA(LIM2+10)
4179  FORMAT(' ',3E12.4,2X,3E12.4,2X,E12.4,I4,3X,E12.4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,108,0.)
      YS = YS - DEL
      CALL CORE(HWORK,51)
      WRITE(cHWORK,4175) (HDATA(LIMLIM+20+I),I=1,10) ! PMF 17/11/99: JUSCRN changed to cHWORK
4175  FORMAT(' ',10I5)
      CALL SYSSYM(XS,YS,SIZE,HWORK,51,0.)
      MULSEC = HDATA(LIMLIM+22)
      IF(MULSEC.LE.0) GO TO 9020
      IVX = 30
4171  IVX1 = 20
      IF(MULSEC+30.LT.IVX+IVX1) IVX1 = MULSEC+30-IVX
      YS = YS - DEL
      CALL CORE(HWORK,101)
      WRITE(cHWORK,4174) (HDATA(LIMLIM+IVX+I),I=1,IVX1) ! PMF 17/11/99: JUSCRN changed to cHWORK
4174  FORMAT(' ',20I5)
      LIMLO = IVX1*5 + 1
      CALL SYSSYM(XS,YS,SIZE,HWORK,LIMLO,0.)
      IVX = IVX + 20
      IF(IVX.GT.30+MULSEC) GO TO 9020
      GO TO 4171
C--------------- SPECIAL FORMAT FOR PATR BANKS
877   LIM2 = LIM2 - 1
      LO = IDATA(LIM2+1)
      NTR = IDATA(LIM2+2)
      LTR = IDATA(LIM2+3)
      IPO = LIM2 + LO
      CALL CORE(HWORK,72)
      WRITE(cHWORK,878) (IDATA(LIM2+II),II=1,LO) ! PMF 17/11/99: JUSCRN changed to cHWORK
878   FORMAT('  ',3I5,2X,Z8,3I5,2X,Z8,4I5)
      LO = LO*5+12
      CALL SYSSYM(XS,YS,SIZE,HWORK,LO,0.)
      IF(NTR.GT.100) RETURN
      ICNT = 0
879   ICNT = ICNT + 1
      IF(ICNT.GT.NTR) GO TO 9020
875   YS = YS - DEL
      IF(YS.GT.50.) GO TO 876
      IRETUR = 2
      GO TO 9965
876   IPP = IPO + (ICNT-1)*LTR
      CALL CORE(HWORK,123)
      WRITE(cHWORK,679) IDATA(IPP+1),(HDATA(IPP*2+I),I=3,4), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ (IDATA(IPP+I),I=3,4),(ADATA(IPP+I),I=5,10),
     1                  IDATA(IPP+11),(ADATA(IPP+I),I=12,17)
679   FORMAT(' ',I2,1X,2(Z2,2X),I5,I3,2X,2F8.3,F10.3,3F7.3,2X,I3,2X,
     1 2F8.3,F10.3,3F7.3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,123,0.)
      YS = YS - DEL
      CALL CORE(HWORK,124)
      WRITE(cHWORK,873) IDATA(IPP+18),(ADATA(IPP+I),I=19,23), ! PMF 17/11/99: JUSCRN changed to cHWORK
     1                  IDATA(IPP+24),(ADATA(IPP+I),I=25,28),
     2                  IDATA(IPP+29),(ADATA(IPP+I),I=30,32),
     3                  IDATA(IPP+33)
873   FORMAT(' ',I2,1X,F10.6,2F8.3,F10.6,F8.3,I3,1X,4F10.6,I2,1X,F10.2,
     1 2F8.2,I3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,124,0.)
      YS = YS - DEL
      CALL CORE(HWORK,122)
      WRITE(cHWORK,872) (IDATA(IPP+I),I=34,48),HDATA(1+2*(IPP+1)), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ HDATA(2+2*(IPP+1))
872   FORMAT('  ',14I6,2X,Z8,2X,' VECTNR',I4,' PART.TYPE',I3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,122,0.)
      GO TO 879
1277  CONTINUE
C--------------- SPECIAL FORMAT FOR GVTX BANKS
      NV = IDATA(LIM2)
      IPO = LIM2
      DO 1278  INV = 1,NV
      IPO = LIM2+(INV-1)*10
      CALL CORE(HWORK,72)
      WRITE(cHWORK,1279) IDATA(IPO+1),(ADATA(IPO+1+JJ),JJ=1,6),IDATA(IPO ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ +8),ADATA(IPO+9),IDATA(IPO+10)
1279  FORMAT(' ',I3,3F8.2,3F8.2,I4,F8.2,I8)
      CALL SYSSYM(XS,YS,SIZE,HWORK,72,0.)
1278  YS = YS - DEL
      NT = IDATA(IPO+11)
      CALL CORE(HWORK,4)
      WRITE(cHWORK,1280) NT ! PMF 17/11/99: JUSCRN changed to cHWORK
1280  FORMAT(' ',I3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,4,0.)
      YS = YS - DEL
      IPO = IPO + 11 - 15
      DO 1281  INT = 1,NT
      IPO = IPO+15
      CALL CORE(HWORK,64)
      WRITE(cHWORK,1282) IDATA(IPO+1),(ADATA(IPO+1+JJ),JJ=1,8) ! PMF 17/11/99: JUSCRN changed to cHWORK
1282  FORMAT(' ',I3,F8.2,2F7.3,3F8.2,2F7.3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,64,0.)
      YS = YS - DEL
      CALL CORE(HWORK,42)
      WRITE(cHWORK,1285) (ADATA(IPO+1+JJ),JJ=9,11), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ IDATA(IPO+13),IDATA(IPO+14),ADATA(IPO+15)
1285  FORMAT(' ',3F8.2,I4,I3,F10.2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,42,0.)
      YS = YS - DEL
      IF(YS.GT.80.) GO TO 1281
      IRETUR = 6
      GO TO 9965
1286  CONTINUE
1281  CONTINUE
      GO TO 9020
1377  CONTINUE
C--------------- SPECIAL FORMAT FOR DEDX BANKS
      NTR = IDATA(LIM2+1)
      CALL CORE(HWORK,4)
      WRITE(cHWORK,1380) NTR ! PMF 17/11/99: JUSCRN changed to cHWORK
1380  FORMAT(' ',I3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,4,0.)
      NTR = MIN0(NTR,60)
      YS = YS - DEL
      DO 1378  ITR = 1,NTR
      IPO = LIM2+1+(ITR-1)*10
      CALL CORE(HWORK,82)
      WRITE(cHWORK,1379) IDATA(IPO+1),(ADATA(IPO+1+JJ),JJ=1,6),IDATA(IPO ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ +8),ADATA(IPO+9)
1379  FORMAT(' ',I3,2F8.2,4E12.4,I4,F10.3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,82,0.)
      YS = YS - DEL
      IF(YS.GT.80.) GO TO 1378
      IRETUR = 7
      GO TO 9965
1376  CONTINUE
1378  CONTINUE
      GO TO 9020
1977  CONTINUE
C--------------- SPECIAL FORMAT FOR TOFR BANKS
      NTR = IDATA(LIM2)
      LIM2 = LIM2 - 1
      CALL CORE(HWORK,17)
      WRITE(cHWORK,1980) (IDATA(LIM2+I),I=1,4) ! PMF 17/11/99: JUSCRN changed to cHWORK
1980  FORMAT(' ',4I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,17,0.)
      YS = YS - DEL
      DO 1978  ITR = 1,NTR
      IPO = LIM2+4+(ITR-1)*14
      CALL CORE(HWORK,118)
      WRITE(cHWORK,1979) (IDATA(IPO+I),I=1,3),(ADATA(IPO+I),I=4,14) ! PMF 17/11/99: JUSCRN changed to cHWORK
1979  FORMAT(' ',3I3,F8.2,F8.0,4F8.2,4F12.3,F12.0)
      CALL SYSSYM(XS,YS,SIZE,HWORK,118,0.)
      YS = YS - DEL
      IF(YS.GT.80.) GO TO 1978
      IRETUR = 9
      GO TO 9965
1976  CONTINUE
1978  CONTINUE
      GO TO 9020
1677  CONTINUE
C--------------- SPECIAL FORMAT FOR LGCL BANKS
      LIM2 = LIM2 - 1
      CALL CORE(HWORK,29)
      WRITE(cHWORK,1680) (IDATA(LIM2+LL),LL=1,4) ! PMF 17/11/99: JUSCRN changed to cHWORK
1680  FORMAT(' ',4I7)
      CALL SYSSYM(XS,YS,SIZE,HWORK,29,0.)
      LIM2 = LIM2 + 4
      YS = YS - DEL
      CALL CORE(HWORK,118)
      WRITE(cHWORK,1681) (IDATA(LIM2+LL),LL=1,6),(ADATA(LIM2+LL),LL=7,1000052800 ! PMF 17/11/99: JUSCRN changed to cHWORK
     $),IDATA(LIM2+11),(ADATA(LIM2+LL),LL=12,15),(IDATA(LIM2+L),L=16,21)
1681  FORMAT(' ',I3,I9,4I4,4F8.3,I4,4F8.3,2I3,I6,3I3)
      CALL SYSSYM(XS,YS,SIZE,HWORK,118,0.)
      NCLST = IDATA(LIM2+3)
      NWPCL = IDATA(LIM2+21)
      ILABEL = IDATA(LIM2+17)
      NCLS2 = NCLST*2+ 2
      LIM2 = LIM2 + 21
      LIM22 = 2*LIM2
      YS = YS - DEL
      CALL CORE(HWORK,101)
      WRITE(cHWORK,1682) ((HDATA(LIM22+L),HDATA(LIM22+L+1)),L=1,NCLS2,2) ! PMF 17/11/99: JUSCRN changed to cHWORK
1682  FORMAT(' ',20I5)
      CALL SYSSYM(XS,YS,SIZE,HWORK,101,0.)
      IF(NCLST.LE.0) GO TO 9020
      LIM2 = LIM2 + NCLST + 1
      YS = YS - DEL
      DO 1678  ITR = 1,NCLST
      IPO = LIM2+(ITR-1)*NWPCL
      CALL CORE(HWORK,119)
C     IF(ILABEL.EQ.2)
      WRITE(cHWORK,1679) IDATA(IPO+1),(ADATA(IPO+1+JJ),JJ=1,6),IDATA(IPO ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ +8),(ADATA(IPO+JJ),JJ=9,NWPCL)
1679  FORMAT(' ',I3,2F8.3,2F9.2,2F8.3,I4,4F8.3,F10.3,2F6.3,F7.3)
C     IF(ILABEL.EQ.1)
C    $WRITE(JUSCRN,1675) IDATA(IPO+1),(ADATA(IPO+1+JJ),JJ=1,6),IDATA(IPO
C    $ +8),(ADATA(IPO+8+JJ),JJ=1,6),IDATA(IPO+15)
C1675  FORMAT(' ',I3,2F8.3,2F9.2,2F8.3,I4,6F9.3,I11)
      CALL SYSSYM(XS,YS,SIZE,HWORK,119,0.)
      YS = YS - DEL
      IF(YS.GT.80.) GO TO 1678
      IRETUR = 8
      GO TO 9965
1676  CONTINUE
1678  CONTINUE
      GO TO 9020
2240  CONTINUE
C--------------- SPECIAL FORMAT FOR FAMP BANKS (NOW TEMPORARILY BK17)
      LIM2 = LIM2 - 1
      LH2 = LIM2*2
      YS = YS - DEL
      CALL CORE(HWORK,28)
      WRITE(cHWORK,2241) HDATA(LH2+3) ! PMF 17/11/99: JUSCRN changed to cHWORK
2241  FORMAT(' FAMP PROGRAM VERSION ',I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,28,0.)
C TRIGGERS
      NTRI = HDATA(LH2+4)
      IF(NTRI.GT.0) GO TO 2242
C      YS = YS - DEL
C      CALL CORE(HWORK,28)
C      WRITE(cHWORK,2243) ! PMF 17/11/99: JUSCRN changed to cHWORK
C2243  FORMAT(' ---> NO TRIGGER INFORMATION')
C      CALL SYSSYM(XS,YS,SIZE,HWORK,28,0.)
       GO TO 2244
2242  YS = YS - DEL
      CALL CORE(HWORK,77)
      WRITE(cHWORK,2245) (HDATA(LH2+NTRI+K),K=1,4) ! PMF 17/11/99: JUSCRN changed to cHWORK
2245  FORMAT(' #T2 TRACKS ',I3,' R3 TRACKS CELLS 33-48 ',Z4,'  CELLS 17-
     $32 ',Z4,'  CELLS 1-16 ',Z4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,77,0.)
C COUNTERS
2244  NCOU = HDATA(LH2+5)
      IF(NCOU.GT.0) GO TO 2246
C     YS = YS - DEL
C     CALL CORE(HWORK,28)
C     WRITE(cHWORK,2247) ! PMF 17/11/99: JUSCRN changed to cHWORK
C2247  FORMAT(' ---> NO COUNTER INFORMATION')
C     CALL SYSSYM(XS,YS,SIZE,HWORK,28,0.)
      GO TO 2248
2246  AA = HDATA(LH2+NCOU+2)*.1
      YS = YS - DEL
      CALL CORE(HWORK,53)
      WRITE(cHWORK,2249) HDATA(LH2+NCOU+1),AA,HDATA(LH2+NCOU+3), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ HDATA(LH2+NCOU+4)
2249  FORMAT(' #TOFS ',I3,' TDIF(NS) ',F8.1,' ZVTOF ',I6,' ZVLG ',I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,53,0.)
C LEAD GLASS
2248  NL = HDATA(LH2+6)
      IF(NL.GT.0) GO TO 2250
C      YS = YS - DEL
C      CALL CORE(HWORK,31)
C      WRITE(cHWORK,2251) ! PMF 17/11/99: JUSCRN changed to cHWORK
C2251  FORMAT(' ---> NO LEAD GLASS INFORMATION')
C      CALL SYSSYM(XS,YS,SIZE,HWORK,31,0.)
      GO TO 2252
2250  AA1 = HDATA(LH2+NL+5)*.001
      AA2 = HDATA(LH2+NL+6)*.001
      AA3 = HDATA(LH2+NL+7)*.001
      AA4 = HDATA(LH2+NL+8)*.001
      YS = YS - DEL
      CALL CORE(HWORK,124)
      WRITE(cHWORK,2253) (HDATA(LH2+NL+K),K=1,4),AA1,AA2,AA3,AA4, ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ (HDATA(LH2+NL+KK),KK=9,10)
2253  FORMAT(' NR CLUSTERS TOTAL,BARREL,-EC,+EC : ',4I5,' ENERGIES: ',
     $4F8.3,' NHCLI ',I6,' ERES ',I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,124,0.)
C INNER DETECTOR ANALYSIS
2252  ND = HDATA(LH2+7)
      IF(ND.GT.0) GO TO 2254
      YS = YS - DEL
      CALL CORE(HWORK,35)
      WRITE(cHWORK,2255) ! PMF 17/11/99: JUSCRN changed to cHWORK
2255  FORMAT(' ---> NO INNER DETECTOR INFORMATION')
      CALL SYSSYM(XS,YS,SIZE,HWORK,35,0.)
      GO TO 2256
2254  CONTINUE
      YS = YS - DEL
      CALL CORE(HWORK,46)
      WRITE(cHWORK,2257) (HDATA(LH2+ND+K),K=1,3) ! PMF 17/11/99: JUSCRN changed to cHWORK
2257  FORMAT(' ID ZVTX FLAG ',I3,'  ZVTX IN MM ',I6,' INRGZV ',I2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,46,0.)
      YS = YS - DEL
      INRGZV = HDATA(LH2+ND+3)
      NTR = HDATA(LH2+ND+4)
      NTRT = HDATA(LH2+ND+5)
      CALL CORE(HWORK,49)
      IF(NTR.LT.0) WRITE(cHWORK,2258) ! PMF 17/11/99: JUSCRN changed to cHWORK
2258  FORMAT(' PATTERN RECOGNITION NOT PERFORMED              ')
      IF(NTR.EQ.0) WRITE(cHWORK,2259) ! PMF 17/11/99: JUSCRN changed to cHWORK
2259  FORMAT(' PATTERN RECOGNITION PERFORMED, NO TRACKS FOUND ')
      IF(NTR.LE.0) CALL SYSSYM(XS,YS,SIZE,HWORK,47,0.)
      IF(NTR.LE.0) GO TO 2256
      WRITE(cHWORK,2260) NTRT,NTR ! PMF 17/11/99: JUSCRN changed to cHWORK
2260  FORMAT(' PATREC PERFORMED,',I3,' TRACKS FOUND',I3,' TRACK BANKS')
      CALL SYSSYM(XS,YS,SIZE,HWORK,49,0.)
      LORT = HDATA(LH2+ND+6)
      LTRT = HDATA(LH2+ND+7)
      MWR1 = HDATA(LH2+ND+8)
      MWR2 = HDATA(LH2+ND+9)
      MWR3 = HDATA(LH2+ND+10)
      IEFA = HDATA(LH2+ND+11)
      IPLT = LH2+ND+LORT-LTRT
      YS = YS - DEL
      CALL CORE(HWORK,102)
      WRITE(cHWORK,2261) NTRT,LORT,LTRT,MWR1,MWR2,MWR3,IEFA ! PMF 17/11/99: JUSCRN changed to cHWORK
2261  FORMAT(' TRACKS LISTED ',I4,'  LO AND LT FOR EACH ',2I4,
     $' NR WORDS MAP RING1-3: ',3I5,' ERROR FLAG ',Z4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,102,0.)
C
      DO 2262  ITR = 1,NTR
      IPLT = IPLT + LTRT
      IFTR = HDATA(IPLT)
      RR1 = HDATA(IPLT+1)*.1
      FI1 = HDATA(IPLT+2)
      Z1 = HDATA(IPLT+3)*.1
      RR2 = HDATA(IPLT+4)*.1
      FI2 = HDATA(IPLT+5)
      Z2 = HDATA(IPLT+6)*.1
      HELP(1) = HDATA(IPLT+8)
      HELP(2) = HDATA(IPLT+9)
      RR = FLOAT(IZWORD)*.1
      SIGXY = HDATA(IPLT+10)*.01
      NXY = HDATA(IPLT+11)
      TANTH = HDATA(IPLT+12)*001
      Z0 = HDATA(IPLT+13)*.1
      SIGZ = HDATA(IPLT+14)*.1
      NZ = HDATA(IPLT+15)
      YS = YS - DEL
      IF(YS.GT.50.) GO TO 2199
      IRETUR = 11
      GO TO 9965
2199  CONTINUE
      CALL CORE(HWORK,120)
      WRITE(6,2263) ITR,IFTR,RR1,FI1,Z1,RR2,FI2,Z2,RR,SIGXY,NXY
2263  FORMAT(' ',I2,' SEC. ',I3,' R-FI-Z 1 ',F8.1,F5.0,F8.1,' R-FI-Z 2 '
     $,F8.1,F5.0,F8.1,' RCURV SIGXY NHITXY ',E14.6,F8.2,I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,120,0.)
C
      YS = YS - DEL
      CALL CORE(HWORK,115)
      WRITE(6,2264) TANTH,Z0,SIGZ,NZ
2264  FORMAT(' ',59X,' TANTHETA ',F10.5,' Z0 ',F8.2,' SIGZ(MM) ',F7.4,
     $ ' NZ ',I2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,115,0.)
C
2262  CONTINUE
      IPLT = IPLT + LTRT
      IPLT1 = IPLT
      IPLT2 = IPLT1+MWR1
      IPLT3 = IPLT2+MWR2
      IPLT4 = IPLT3+MWR3
      YS = YS - DEL
      IF(YS.GT.50.) GO TO 2299
      IRETUR = 12
      GO TO 9965
2299  CONTINUE
      CALL CORE(HWORK,44)
      WRITE(6,2291) IPLT1,IPLT2,IPLT3,IPLT4
2291  FORMAT(' FAMP HIT MAP POINTERS: ',4I5)
      CALL SYSSYM(XS,YS,SIZE,HWORK,44,0.)
      IF(IPLT2.EQ.IPLT1) GO TO 2292
2295  IPLT22 = IPLT2-1
      IF(IPLT22.GT.IPLT1+19) IPLT22 = IPLT1+19
      IRESV = 22+5*(IPLT22-IPLT1+1)
      YS = YS - DEL
      IF(YS.GT.50.) GO TO 2399
      IRETUR = 13
      GO TO 9965
2399  CONTINUE
      CALL CORE(HWORK,IRESV)
      WRITE(6,2293) (HDATA(II),II=IPLT1,IPLT22)
 2293  FORMAT(' ',14X,' RING1 ',20(Z4,1X))
      CALL SYSSYM(XS,YS,SIZE,HWORK,IRESV,0.)
      IF(IPLT22.GE.IPLT2-1) GO TO 2292
      IPLT1 = IPLT22+1
      GO TO 2295
2292  CONTINUE
      IF(IPLT3.EQ.IPLT2) GO TO 2296
2297  IPLT33 = IPLT3-1
      IF(IPLT33.GT.IPLT2+19) IPLT33 = IPLT2+19
      IRESV = 22+5*(IPLT33-IPLT2+1)
      YS = YS - DEL
      IF(YS.GT.50.) GO TO 2499
      IRETUR = 14
      GO TO 9965
2499  CONTINUE
      CALL CORE(HWORK,IRESV)
      WRITE(6,2298) (HDATA(II),II=IPLT2,IPLT33)
2298  FORMAT(' ',14X,' RING2 ',20(Z4,1X))
      CALL SYSSYM(XS,YS,SIZE,HWORK,IRESV,0.)
      IF(IPLT33.GE.IPLT3-1) GO TO 2296
      IPLT2 = IPLT33+1
      GO TO 2297
2296  CONTINUE
      IF(IPLT4.EQ.IPLT3) GO TO 2301
      IF(INRGZV.NE.3) GO TO 2301
2302  IPLT44 = IPLT3-1
      IF(IPLT44.GT.IPLT3+19) IPLT44 = IPLT3+19
      IRESV = 22+5*(IPLT44-IPLT3+1)
      YS = YS - DEL
      IF(YS.GT.50.) GO TO 2599
      IRETUR = 15
      GO TO 9965
2599  CONTINUE
      CALL CORE(HWORK,IRESV)
      WRITE(6,2303) (HDATA(II),II=IPLT3,IPLT44)
2303  FORMAT(' ',14X,' RING3 ',20(Z4,1X))
      CALL SYSSYM(XS,YS,SIZE,HWORK,IRESV,0.)
      IF(IPLT44.GE.IPLT4-1) GO TO 2301
      IPLT3 = IPLT44+1
      GO TO 2302
2301  CONTINUE
C
2256  NM = HDATA(LH2+8)
      IF(NM.GT.0) GO TO 2266
C      YS = YS - DEL
C      CALL CORE(HWORK,25)
C      WRITE(cHWORK,2267) ! PMF 17/11/99: JUSCRN changed to cHWORK
C2267  FORMAT(' ---> NO MUON INFORMATION')
C      CALL SYSSYM(XS,YS,SIZE,HWORK,25,0.)
      GO TO 2268
2266  CONTINUE
      YS = YS - DEL
      NMU = HDATA(LH2+NM)
      IF(NMU.GT.5) NMU =  5
      NCORE = 44 + NMU*4
      NMU = 2*NMU + 1
      CALL CORE(HWORK,64)
      WRITE(cHWORK,2269) HDATA(LH2+NM),HDATA(LH2+NM+1), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ (HDATA(LH2+NM+K),K=2,NMU,2)
2269  FORMAT(' NR MUON TRACKS ',I2,'   IN BARREL ',I3,' POSITION ',5I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,NCORE,0.)
      YS = YS - DEL
      CALL CORE(HWORK,64)
      WRITE(cHWORK,2270) (HDATA(LH2+NM+K+1),K = 2,NMU,2) ! PMF 17/11/99: JUSCRN changed to cHWORK
2270  FORMAT('                ',3X,'             ',3X,' QUALITY ',5I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,NCORE,0.)
C
2268  CONTINUE
      NTG = HDATA(LH2+9)
      IF(NTG.GT.0) GO TO 2271
C     YS = YS - DEL
C     CALL CORE(HWORK,25)
C     WRITE(cHWORK,2272) ! PMF 17/11/99: JUSCRN changed to cHWORK
C2272  FORMAT(' ---> NO TAGG INFORMATION')
C     CALL SYSSYM(XS,YS,SIZE,HWORK,25,0.)
      GO TO 2273
2271  CONTINUE
      YS = YS - DEL
      CALL CORE(HWORK,50)
      WRITE(cHWORK,2274) (HDATA(LH2+NTG+K),K=1,2) ! PMF 17/11/99: JUSCRN changed to cHWORK
2274  FORMAT(' TAGGING ENERGIES(MEV) IN -Z, +Z: ',2I8)
      CALL SYSSYM(XS,YS,SIZE,HWORK,50,0.)
C
2273  CONTINUE
C WRITE NOW FAMP ACTION WORD, FROM THE HEADBANK
C     IPHEA = IDATA(IBLN('HEAD'))
C     FAMACT = HDATA(2*IPHEA+26)
C     YS = YS - DEL
C     CALL CORE(HWORK,45)
C     WRITE(cHWORK,2275) FAMACT ! PMF 17/11/99: JUSCRN changed to cHWORK
C2275  FORMAT('  FAMP ACTION WORD FROM HEAD BANK 26: ',Z4)
C      CALL SYSSYM(XS,YS,SIZE,HWORK,45,0.)
      GO TO 9020
C-------------------------
C----   SPECIAL FORMAT FOR ZTRG BANKS
C-------------------------
2550  CONTINUE
      LIM2 = LIM2 - 1
      LEZTRG = IDATA(LIM2)
      HPOINT = 2*( LIM2 + 1 )
      HZLENG = 2*( LEZTRG - 1 )
      YS = YS - DEL
C                    WRITE HEADER
      IILIM = 110
      CALL CORE(HWORK,IILIM)
      WRITE(cHWORK,2551) ! PMF 17/11/99: JUSCRN changed to cHWORK
 2551 FORMAT(' DATA  B15 CHANNEL FIFOF HITCN UFLOW OFLOW Z-VALUE',10X,
     $' DATA  B15 CHANNEL FIFOF HITCN UFLOW OFLOW Z-VALUE')
      CALL SYSSYM(XS,YS,SIZE,HWORK,IILIM,0.)
C
      DO 2553 IHIT = 1,HZLENG,2
        HELP(2) = HDATA(HPOINT+IHIT)
        IZWRD1 = IZWORD
        KANAL1 = LAND( ISHFTR(IZWORD,11),15)
        HITCN1 = LAND( ISHFTR(IZWORD,8),3)
        IBT151 = 0
        IF(TBIT(IZWORD,16)) IBT151 = 1
        IZWRT1 = LAND( IZWORD,63 )
        IOVRF1 = 0
        IF(LAND(IZWORD,64).NE.0) IOVRF1 = 1
        IUNDF1 = 0
        IF(LAND(IZWORD,128).NE.0) IUNDF1 = 1
        IFIFF1 = 0
        IF(LAND(IZWORD,1024).NE.0) IFIFF1 = 1
C
        HELP(2) = HDATA(HPOINT+IHIT+1)
        IZWRD2 = IZWORD
        KANAL2 = LAND( ISHFTR(IZWORD,11),15)
        HITCN2 = LAND( ISHFTR(IZWORD,8),3)
        IBT152 = 0
        IF(TBIT(IZWORD,16)) IBT152 = 1
        IZWRT2 = LAND( IZWORD,63 )
        IOVRF2 = 0
        IF(LAND(IZWORD,64).NE.0) IOVRF2 = 1
        IUNDF2 = 0
        IF(LAND(IZWORD,128).NE.0) IUNDF2 = 1
        IFIFF2 = 0
        IF(LAND(IZWORD,1024).NE.0) IFIFF2 = 1
C
        YS = YS - DEL
        IF(YS.GT.50.) GO TO 2554
      IRETUR = 16
      GO TO 9965
2554    IILIM = 108
        CALL CORE(HWORK,IILIM)
        WRITE(cHWORK,2552) IZWRD1,IBT151,KANAL1,IFIFF1,HITCN1,IUNDF1, ! PMF 17/11/99: JUSCRN changed to cHWORK
     $  IOVRF1,IZWRT1,
     $  IZWRD2,IBT152,KANAL2,IFIFF2,HITCN2,IUNDF2,
     $  IOVRF2,IZWRT2
 2552   FORMAT(' ',Z4,3X,I1,4X,I2,5X,I1,5X,I1,5X,I1,5X,I1,4X,I5,
     $ 13X,Z4,3X,I1,4X,I2,5X,I1,5X,I1,5X,I1,5X,I1,4X,I5)
        CALL SYSSYM(XS,YS,SIZE,HWORK,IILIM,0.)
 2553 CONTINUE
C
      GO TO 9020
3235  CONTINUE
C--------------- SPECIAL FORMAT FOR N50S BANKS
      LIM2 = LIM2 - 1
      LH2 = LIM2*2
      YS = YS - DEL
      CALL CORE(HWORK,86)
      WRITE(cHWORK,3236) HDATA(LH2+3),HDATA(LH2+11),HDATA(LH2+12) ! PMF 17/11/99: JUSCRN changed to cHWORK
3236  FORMAT(' N50 PROGRAM VERSION ',I6,' ANALYSIS FLAG ',Z4,'  LOOSE MU
     $LTIHADRON SELECTION FLAG ',I5)
      CALL SYSSYM(XS,YS,SIZE,HWORK,86,0.)
C TRIGGERS
      NTRI = HDATA(LH2+4)
      IF(NTRI.GT.0) GO TO 3227
      YS = YS - DEL
      CALL CORE(HWORK,28)
      WRITE(cHWORK,3228) ! PMF 17/11/99: JUSCRN changed to cHWORK
3228  FORMAT(' ---> NO TRIGGER INFORMATION')
      CALL SYSSYM(XS,YS,SIZE,HWORK,28,0.)
      GO TO 3229
3227  YS = YS - DEL
      CALL CORE(HWORK,77)
      WRITE(cHWORK,3231) (HDATA(LH2+NTRI+K),K=1,4) ! PMF 17/11/99: JUSCRN changed to cHWORK
3231  FORMAT(' #T2 TRACKS ',I3,' R3 TRACKS CELLS 33-48 ',Z4,'  CELLS 17-
     $32 ',Z4,'  CELLS 1-16 ',Z4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,77,0.)
C COUNTERS
3229  NCOU = HDATA(LH2+5)
      IF(NCOU.GT.0) GO TO 3237
      YS = YS - DEL
      CALL CORE(HWORK,28)
      WRITE(cHWORK,3238) ! PMF 17/11/99: JUSCRN changed to cHWORK
3238  FORMAT(' ---> NO COUNTER INFORMATION')
      CALL SYSSYM(XS,YS,SIZE,HWORK,28,0.)
      GO TO 3239
3237  AA = HDATA(LH2+NCOU+2)*.1
      YS = YS - DEL
      CALL CORE(HWORK,53)
      WRITE(cHWORK,3241) HDATA(LH2+NCOU+1),AA,HDATA(LH2+NCOU+3), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ HDATA(LH2+NCOU+4)
3241  FORMAT(' #TOFS ',I3,' TDIF(NS) ',F8.1,' ZVTOF ',I6,' ZVLG ',I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,53,0.)
C LEAD GLASS
3239  NL = HDATA(LH2+6)
      IF(NL.GT.0) GO TO 3242
      YS = YS - DEL
      CALL CORE(HWORK,31)
      WRITE(cHWORK,3243) ! PMF 17/11/99: JUSCRN changed to cHWORK
3243  FORMAT(' ---> NO LEAD GLASS INFORMATION')
      CALL SYSSYM(XS,YS,SIZE,HWORK,31,0.)
      GO TO 3244
3242  AA1 = HDATA(LH2+NL+5)*.001
      AA2 = HDATA(LH2+NL+6)*.001
      AA3 = HDATA(LH2+NL+7)*.001
      AA4 = HDATA(LH2+NL+8)*.001
      YS = YS - DEL
      CALL CORE(HWORK,124)
      WRITE(cHWORK,3245) (HDATA(LH2+NL+K),K=1,4),AA1,AA2,AA3,AA4, ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ (HDATA(LH2+NL+KK),KK=9,10)
3245  FORMAT(' NR CLUSTERS TOTAL,BARREL,-EC,+EC : ',4I5,' ENERGIES: ',
     $4F8.3,' NHCLI ',I6,' ERES ',I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,124,0.)
C INNER DETECTOR ANALYSIS
3244  ND = HDATA(LH2+7)
      IF(ND.GT.0) GO TO 3246
      YS = YS - DEL
      CALL CORE(HWORK,35)
      WRITE(cHWORK,3247) ! PMF 17/11/99: JUSCRN changed to cHWORK
3247  FORMAT(' ---> NO INNER DETECTOR INFORMATION')
      CALL SYSSYM(XS,YS,SIZE,HWORK,35,0.)
      GO TO 3248
3246  CONTINUE
      YS = YS - DEL
      CALL CORE(HWORK,46)
      WRITE(cHWORK,3249) (HDATA(LH2+ND+K),K=1,3) ! PMF 17/11/99: JUSCRN changed to cHWORK
3249  FORMAT(' ID ZVTX FLAG ',I3,'  ZVTX IN MM ',I6,' INRGZV ',I2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,46,0.)
      YS = YS - DEL
      NTR = HDATA(LH2+ND+4)
      NTRT = HDATA(LH2+ND+5)
      CALL CORE(HWORK,47)
      IF(NTR.LT.0) WRITE(cHWORK,3250) ! PMF 17/11/99: JUSCRN changed to cHWORK
3250  FORMAT(' PATTERN RECOGNITION NOT PERFORMED             ')
      IF(NTR.EQ.0) WRITE(cHWORK,3251) ! PMF 17/11/99: JUSCRN changed to cHWORK
3251  FORMAT(' PATTERN RECOGNITION PERFORMED, NO TRACKS FOUND')
      IF(NTR.LE.0) CALL SYSSYM(XS,YS,SIZE,HWORK,47,0.)
      IF(NTR.LE.0) GO TO 3248
      WRITE(cHWORK,3252) NTR ! PMF 17/11/99: JUSCRN changed to cHWORK
3252  FORMAT(' PATTERN RECOGNITION PERFORMED,',I3,' TRACKS FOUND')
      CALL SYSSYM(XS,YS,SIZE,HWORK,47,0.)
      LORT = HDATA(LH2+ND+6)
      LTRT = HDATA(LH2+ND+7)
      IPLT = LH2+ND+LORT-LTRT
      YS = YS - DEL
      CALL CORE(HWORK,48)
      WRITE(cHWORK,3212) NTRT,LORT,LTRT ! PMF 17/11/99: JUSCRN changed to cHWORK
3212  FORMAT(' TRACKS LISTED ',I4,'  LO AND LT FOR EACH ',2I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,48,0.)
C
      DO 4614  ITR = 1,NTRT
      IPLT = IPLT + LTRT
      X1 = HDATA(IPLT+1)*.1
      Y1 = HDATA(IPLT+2)*.1
      Z1 = HDATA(IPLT+3)*.1
      X2 = HDATA(IPLT+4)*.1
      Y2 = HDATA(IPLT+5)*.1
      Z2 = HDATA(IPLT+6)*.1
      HELP(1) = HDATA(IPLT+8)
      HELP(2) = HDATA(IPLT+9)
      RR = FLOAT(IZWORD)*.1
      SIGXY = HDATA(IPLT+10)*10.
      NXY = HDATA(IPLT+11)
      TANTH = HDATA(IPLT+12)
      Z0 = HDATA(IPLT+13)*.1
      SIGZ = HDATA(IPLT+14)*.1
      NZ = HDATA(IPLT+15)
      YS = YS - DEL
      CALL CORE(HWORK,114)
      WRITE(6,461) ITR,X1,Y1,Z1,X2,Y2,Z2,RR,SIGXY,NXY
461   FORMAT(' ',I2,' XYZ1 ',3F8.1,' XYZ2 ',3F8.1,' RADIUS ',E14.6,
     $'  SIGXY(MY) ',F10.0,' NXY ',I2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,114,0.)
C
      YS = YS - DEL
      CALL CORE(HWORK,114)
      WRITE(6,462) TANTH,Z0,SIGZ,NZ
462   FORMAT(' ',59X,' TANTHETA ',F10.0,' Z0 ',F8.1,' SIGZ(MM) ',F6.1,
     $ ' NZ ',I2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,114,0.)
C
4614  CONTINUE
C
3248  NM = HDATA(LH2+8)
      IF(NM.GT.0) GO TO 3253
      YS = YS - DEL
      CALL CORE(HWORK,25)
      WRITE(cHWORK,3254) ! PMF 17/11/99: JUSCRN changed to cHWORK
3254  FORMAT(' ---> NO MUON INFORMATION')
      CALL SYSSYM(XS,YS,SIZE,HWORK,25,0.)
      GO TO 3255
3253  CONTINUE
      YS = YS - DEL
      NMU = HDATA(LH2+NM)
      IF(NMU.GT.5) NMU =  5
      NCORE = 44 + NMU*4
      NMU = 2*NMU + 1
      CALL CORE(HWORK,64)
      WRITE(cHWORK,3256) HDATA(LH2+NM),HDATA(LH2+NM+1), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ (HDATA(LH2+NM+K),K=2,NMU,2)
3256  FORMAT(' NR MUON TRACKS ',I2,'   IN BARREL ',I3,' POSITION ',5I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,NCORE,0.)
      YS = YS - DEL
      CALL CORE(HWORK,64)
      WRITE(cHWORK,3257) (HDATA(LH2+NM+K+1),K = 2,NMU,2) ! PMF 17/11/99: JUSCRN changed to cHWORK
3257  FORMAT('                ',3X,'             ',3X,' QUALITY ',5I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,NCORE,0.)
C
3255  CONTINUE
      NTG = HDATA(LH2+9)
      IF(NTG.GT.0) GO TO 3283
      YS = YS - DEL
      CALL CORE(HWORK,25)
      WRITE(cHWORK,3284) ! PMF 17/11/99: JUSCRN changed to cHWORK
3284  FORMAT(' ---> NO TAGG INFORMATION')
      CALL SYSSYM(XS,YS,SIZE,HWORK,25,0.)
      GO TO 3285
3283  CONTINUE
      YS = YS - DEL
      CALL CORE(HWORK,50)
      WRITE(cHWORK,3286) (HDATA(LH2+NTG+K),K=1,2) ! PMF 17/11/99: JUSCRN changed to cHWORK
3286  FORMAT(' TAGGING ENERGIES(MEV) IN -Z, +Z: ',2I8)
      CALL SYSSYM(XS,YS,SIZE,HWORK,50,0.)
C
3285  CONTINUE
C WRITE NOW N50 ACTION WORD, FROM THE HEADBANK
      IPHEA = IDATA(IBLN('HEAD'))
      N50ACT = HDATA(2*IPHEA+26)
      YS = YS - DEL
      CALL CORE(HWORK,45)
      WRITE(cHWORK,3258) N50ACT ! PMF 17/11/99: JUSCRN changed to cHWORK
3258  FORMAT('  NORD 50 ACTION WORD FROM HEAD BANK 26: ',Z4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,45,0.)
C
      IF(LAND(N50ACT,MASKMH).NE.0) GO TO 3263
      N50ACT = ISHFTL(N50ACT,1)
      DO 3232 IBT = 1,16
      N50ACT = ISHFTR(N50ACT,1)
      IF(IBT.LT.6) GO TO 3232
      IF(.NOT.TBIT(N50ACT,31)) GO TO 3232
C BIT IBT IS ON, WRITE CORRESPONDING INFORMATION
      DO 3287  I = 1,13
3287  HDUM(I) = HSX(I,IBT)
      YS = YS - 2*DEL
      CALL CORE(HWORK,43)
      WRITE(cHWORK,3261) (HDUM(I),I=1,13) ! PMF 17/11/99: JUSCRN changed to cHWORK
3261  FORMAT('  CLASSIFICATION ',13A2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,43,0.)
3232  CONTINUE
      GO TO 3264
3263  MUH = LAND(N50ACT,MASKMH)
      DO 3289  I = 1,13
3289  HDUM(I) = HSX(I,5)
      YS = YS - 2*DEL
      CALL CORE(HWORK,61)
      WRITE(cHWORK,3262) (HDUM(I),I=1,13),MUH ! PMF 17/11/99: JUSCRN changed to cHWORK
3262  FORMAT('  CLASSIFICATION ',13A2,' MULTIPLICITY ',I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,61,0.)
3264  CONTINUE
C
C MPRS BANK PART, INCLUDE SO THAT ALSO INDEPENDENT PRINT POSSIBLE
C
      IPLNAM = IDATA(IBLN('MPRS'))
      IF(IPLNAM.LE.0) GO TO 9020
      LIM2=IPLNAM+1
      YS = YS - DEL
      CALL CORE(HWORK,54)
      WRITE(cHWORK,6231) ! PMF 17/11/99: JUSCRN changed to cHWORK
6231  FORMAT(' ------------->>>   MIPROC RESULTS   <<<--------------')
      CALL SYSSYM(XS,YS,SIZE,HWORK,54,0.)
C---------
1940  LIM2 = LIM2 - 1
      LH2 = LIM2*2
      YS = YS - DEL
      CALL CORE(HWORK,46)
      WRITE(cHWORK,6232) HDATA(LH2+10) ! PMF 17/11/99: JUSCRN changed to cHWORK
6232  FORMAT(' MIPROC EVENT COUNT (=TRIGGER NUMBER) ',I8)
      CALL SYSSYM(XS,YS,SIZE,HWORK,46,0.)
C
      YS = YS - DEL
      CALL CORE(HWORK,59)
      WRITE(cHWORK,6233) HDATA(LH2+4),(HDATA(LH2+K),K=7,9) ! PMF 17/11/99: JUSCRN changed to cHWORK
6233  FORMAT(' MIPROC ZVTX',I6,' ZVX AND BACKG. PEAKS',2I6,' FLAG ',I2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,59,0.)
C
      YS = YS - DEL
      CALL CORE(HWORK,27)
      WRITE(cHWORK,6234) HDATA(LH2+5) ! PMF 17/11/99: JUSCRN changed to cHWORK
6234  FORMAT(' MIPROC FOUND ',I3,' R3 TRACKS')
      CALL SYSSYM(XS,YS,SIZE,HWORK,27,0.)
C
      YS = YS - DEL
      CALL CORE(HWORK,37)
      WRITE(cHWORK,6235) HDATA(LH2+3) ! PMF 17/11/99: JUSCRN changed to cHWORK
6235  FORMAT(' MIPROC REJECTION AND ERROR FLAG ',Z4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,37,0.)
C
      MIPROC = HDATA(LH2+3)
      MIPROC = ISHFTL(MIPROC,1)
      DO 8232 IBT = 1,16
      MIPROC = ISHFTR(MIPROC,1)
      IF(.NOT.TBIT(MIPROC,31)) GO TO 8232
C BIT IBT IS ON, WRITE CORRESPONDING INFORMATION
      DO 8287  I = 1,13
8287  HDUM(I) = HSY(I,IBT)
      YS = YS - DEL
      CALL CORE(HWORK,41)
      WRITE(cHWORK,8261) (HDUM(I),I=1,13) ! PMF 17/11/99: JUSCRN changed to cHWORK
8261  FORMAT('  ACTION/ERROR ',13A2)
      CALL SYSSYM(XS,YS,SIZE,HWORK,41,0.)
8232  CONTINUE
C
      GO TO 9020
1577  CONTINUE
C--------------- SPECIAL FORMAT FOR ZVTX BANKS
      LIM2 = LIM2 - 1
      CALL CORE(HWORK,50)
      WRITE(cHWORK,1579) (ADATA(LIM2+I),I=1,3),(IDATA(LIM2+I),I=4,6) ! PMF 17/11/99: JUSCRN changed to cHWORK
1579  FORMAT('  ',3F10.3,3I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,50,0.)
      GO TO 9020
C--------------- SPECIAL FORMAT FOR TPEV BANK
2077  LIM2 = LIM2 - 1
      LIMH2 = 2*LIM2
      CALL CORE(HWORK,62)
      WRITE(cHWORK,2079) IDATA(LIM2+1),IDATA(LIM2+2),(HDATA(LIMH2+I),I= ! PMF 17/11/99: JUSCRN changed to cHWORK
     $5,14)
2079  FORMAT('  ',I8,2X,I8,2X,10I4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,62,0.)
      YS = YS - DEL
      CALL CORE(HWORK,114)
      WRITE(cHWORK,2080) (HDATA(LIMH2+I),I=15,34) ! PMF 17/11/99: JUSCRN changed to cHWORK
2080  FORMAT('  ',16I5,4I8)
      CALL SYSSYM(XS,YS,SIZE,HWORK,114,0.)
      YS = YS - DEL
      CALL CORE(HWORK,122)
      WRITE(cHWORK,2081) (ADATA(LIM2+I),I=18,27) ! PMF 17/11/99: JUSCRN changed to cHWORK
2081  FORMAT('  ',10E12.4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,122,0.)
      YS = YS - DEL
      CALL CORE(HWORK,54)
      WRITE(cHWORK,2082)(HDATA(LIMH2+I),I=55,56),(ADATA(LIM2+I),I=29,31) ! PMF 17/11/99: JUSCRN changed to cHWORK
2082  FORMAT('  ',2I5,3E14.6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,54,0.)
      YS = YS - DEL
      CALL CORE(HWORK,110)
      WRITE(cHWORK,2083) (ADATA(LIM2+I),I=32,40) ! PMF 17/11/99: JUSCRN changed to cHWORK
2083  FORMAT('  ',9E12.4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,110,0.)
      YS = YS - DEL
      CALL CORE(HWORK,120)
      WRITE(cHWORK,2084)(HDATA(LIMH2+I),I=81,82),(ADATA(LIM2+I),I=42,50) ! PMF 17/11/99: JUSCRN changed to cHWORK
2084  FORMAT('  ',2I5,9E12.4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,120,0.)
      YS = YS - DEL
      CALL CORE(HWORK,72)
      WRITE(cHWORK,2085) (ADATA(LIM2+I),I=51,55) ! PMF 17/11/99: JUSCRN changed to cHWORK
2085  FORMAT('  ',5E14.6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,72,0.)
      YS = YS - DEL
      CALL CORE(HWORK,52)
      WRITE(cHWORK,2086) (HDATA(LIMH2+I),I=111,120) ! PMF 17/11/99: JUSCRN changed to cHWORK
2086  FORMAT('  ',10I5)
      CALL SYSSYM(XS,YS,SIZE,HWORK,52,0.)
      GO TO 9020
C--------------- SPECIAL FORMAT FOR TPTR BANKS
2177  LIM2 = LIM2 - 1
      LIMH2 = 2*LIM2
      CALL CORE(HWORK,110)
      WRITE(cHWORK,2179) (HDATA(LIMH2+I),I=1,18) ! PMF 17/11/99: JUSCRN changed to cHWORK
2179  FORMAT('  ',18I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,110,0.)
      YS = YS - DEL
      CALL CORE(HWORK,122)
      WRITE(cHWORK,2180) (ADATA(LIM2+I),I=10,19) ! PMF 17/11/99: JUSCRN changed to cHWORK
2180  FORMAT('  ',10E12.4)
      CALL SYSSYM(XS,YS,SIZE,HWORK,122,0.)
      YS = YS - DEL
      CALL CORE(HWORK,78)
      WRITE(cHWORK,2181) IDATA(LIM2+20),ADATA(LIM2+21),IDATA(LIM2+22), ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ (ADATA(LIM2+I),I=23,25),IDATA(LIM2+26)
2181  FORMAT('  ',I6,E14.6,I6,3E14.6,I8)
      CALL SYSSYM(XS,YS,SIZE,HWORK,78,0.)
      YS = YS - DEL
      CALL CORE(HWORK,112)
      WRITE(cHWORK,2182)(ADATA(LIM2+I),I=27,33),(HDATA(LIMH2+I),I=67,68) ! PMF 17/11/99: JUSCRN changed to cHWORK
2182  FORMAT('  ',7E14.6,2I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,112,0.)
      YS = YS - DEL
      CALL CORE(HWORK,112)
      WRITE(cHWORK,2183)(ADATA(LIM2+I),I=35,38),(HDATA(LIMH2+I),I=77,78) ! PMF 17/11/99: JUSCRN changed to cHWORK
     $,(ADATA(LIM2+I),I=40,42)
2183  FORMAT('  ',4E14.6,2I6,3E14.6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,112,0.)
      YS = YS - DEL
      CALL CORE(HWORK,74)
      WRITE(cHWORK,2184) (HDATA(LIMH2+I),I=85,96) ! PMF 17/11/99: JUSCRN changed to cHWORK
2184  FORMAT('  ',12I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,74,0.)
      YS = YS - DEL
      CALL CORE(HWORK,120)
      WRITE(cHWORK,2185) (ADATA(LIM2+I),I=49,57) ! PMF 17/11/99: JUSCRN changed to cHWORK
2185  FORMAT('   ',9E13.5)
      CALL SYSSYM(XS,YS,SIZE,HWORK,120,0.)
      YS = YS - DEL
      CALL CORE(HWORK,86)
      WRITE(cHWORK,2186) IDATA(LIM2+58),(ADATA(LIM2+I),I=59,64) ! PMF 17/11/99: JUSCRN changed to cHWORK
2186  FORMAT('   ',I5,6E13.5)
      CALL SYSSYM(XS,YS,SIZE,HWORK,86,0.)
      YS = YS - DEL
      CALL CORE(HWORK,100)
      WRITE(cHWORK,2187) (ADATA(LIM2+I),I=65,71) ! PMF 17/11/99: JUSCRN changed to cHWORK
2187  FORMAT('  ',7E14.6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,100,0.)
      YS = YS - DEL
      CALL CORE(HWORK,98)
      WRITE(cHWORK,2188) IDATA(LIM2+72),(ADATA(LIM2+I),I=73,78) ! PMF 17/11/99: JUSCRN changed to cHWORK
     $ ,(IDATA(LIM2+I),I=79,80)
2188  FORMAT('  ',I6,6E13.5,2I6)
      CALL SYSSYM(XS,YS,SIZE,HWORK,98,0.)
      GO TO 9020
C____________________________ SPECIAL FORMAT FOR ZETC BANK
5177  LENGB = LENGB + 2
      NCYCLE=1+(LENGB-1)/20
      LENGB = LENGB - 2
      DO 5010 LHO=1,NCYCLE
5006  YS = YS - DEL
      IF(YS.GT.50.) GO TO 5012
      IRETUR = 10
      GO TO 9965
5012  LIML=2*LIM2+20*(LHO-1)+1
      LIMU = LIML + 19
      IF(LIMU.GT.(2*LIM2+LENGB)) LIMU=2*LIM2+LENGB
      ILIM = LIMU - LIML + 1
      IF(ILIM.LE.0) GO TO 9020
      DO 5025  I = 1,ILIM
      LLO = LIML + I - 1
5025  HWORK(I+100) = HDATA(LLO)
      DO 5027  I = 1,ILIM,4
      IX = HWORK(I+100)
      IX = ISHFTR(IX,3)
5027  HWORK(I+100) = IX
5026  IILIM = 6*ILIM + 1
      CALL CORE(HWORK,IILIM)
      WRITE(cHWORK,9011) (HWORK(LLO+100),LLO=1,ILIM) ! PMF 17/11/99: JUSCRN changed to cHWORK
      CALL SYSSYM(XS,YS,SIZE,HWORK,IILIM,0.)
 5010 CONTINUE
      GO TO 9020
C---------------    CONTINUATION SECTION
9965  CALL CORE(HWORK,14)
      WRITE(cHWORK,9005) ! PMF 17/11/99: JUSCRN changed to cHWORK
9005  FORMAT(' CONTINUED ...')
      CALL SYSSYM(XS,YS,SIZE,HWORK,14,0.)
      GO TO 9029
9020  IRETUR = 1
9029  CALL TRMOUT(80,'HARDCOPY ?^')
      CALL DECIDE(IANSW)
      IF(IANSW.NE.1) GO TO 5901
      CALL TRMOUT(80,'HARDCOPY ON EXTERNAL PLOTTER ?^')
      CALL DECIDE(JANSW)
      IF(JANSW.EQ.2) CALL HDCOPY
      IF(JANSW.EQ.1) CALL HDCEXT
5901  IF(IRETUR.EQ.1) GO TO 9566
      IF(IANSW.EQ.1) CALL PROMPT
      CALL ERASE
      YS = IYT
      CALL TRMOUT(80,'TERMINATE THIS LISTING?^')
      CALL DECIDE(IANSW)
      IF(IANSW.EQ.1) GO TO 9566
      CALL ERASE
      GO TO (9566,875,275,9006,8006,1286,1376,1676,1976,5012,2199,
     $ 2299,2399,2499,2599,2554),IRETUR
9566  RETURN
      END
