C   02/02/82 504152032  MEMBER NAME  TBGDIS   (JADEGS)      FORTRAN
      SUBROUTINE TBGDIS
      IMPLICIT INTEGER*2 (H)
C---
C---     DISPLAYS BARREL GROUPS AND SEPTENCES, ECAP QUADRANTS ETC.,
C---     ACCORDING TO LATCHES SET, FOR 1982 -      DATA FORMAT
C---
C---  LAST CHANGE  15.4.1985                   J.OLSSON  23.1.1982
C---
      LOGICAL TBIT,DSPDTM
#include "cdata.for"
#include "cgeo1.for"
#include "cgraph.for"
      COMMON /CGRAP2/ BCMD,DSPDTM(30)
      COMMON/CJTRIG/PI,TWOPI,PIHALF
      DIMENSION HMW(20)
      DIMENSION HELP(2),RF(3),HRF(42)
      EQUIVALENCE (ICAMWD,HELP(1))
      DATA HELP /0,0/,MASK2/Z60000/
      DATA HRF/1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,
     $ 1,2,3,1,2,3,1,2,3,1,2,3,1,2,3/
      DATA ICALL/0/
*** PMF 17/11/99: add variables needed for emulation of DESYLIB routine 'CORE'  
      CHARACTER cHMW*40
      EQUIVALENCE (cHMW,HMW(1))
*** PMF(end)

      IF(ICALL.NE.0) GO TO 10
      ICALL=1
      RF(1) = RLG - 60.
      RF(2) = RLG - 40.
      RF(3) = RLG - 20.
      R7 = OUTR2 + 50.
      R4 = 21.
      DEFI = TWOPI/42.
      DEFI7 = TWOPI/7.
      DEFIH = .5*DEFI
      EPS = .1*DEFIH
      L7 = 14
      NN4 = 40
   10 CONTINUE
      IF(LASTVW.NE.12.AND.LASTVW.NE.15) GO TO 3500
      WRITE (6,3501)
3501  FORMAT(' NOT AVAILABLE IN THIS VIEW...')
      RETURN
3500  IPJ=IDATA(IBLN('LATC'))
      IF(IPJ.GT.0) GO TO 2740
      WRITE(6,275)
275   FORMAT(' NO LATC BANK IN THIS EVENT..')
      RETURN
2740  IBN=IDATA(IPJ+1)
      IF(LAND(IBN,MASK2).NE.0) GO TO 1
      WRITE(6,276) IBN,IBN,MASK2
276   FORMAT(' BANK DESC = ',I6,1X,Z8,' MASK2 = ',Z8,' DISPLAY NOT POSSI
     $BLE')
      RETURN
1     IPJH = 2*IPJ
      IF(LASTVW.GT.3) GO TO 7774
      J1 = IPJH + 14
      J2 = IPJH + 19
C
C LOOP OVER THE BARREL GROUPS
C
      NBIT=7
      DO 32 JK = J1,J2
      HELP(2) = HDATA(JK)
      ICAMWD = ISHFTL(ICAMWD,1)
      DO 32 IBT = 1,NBIT
      ICAMWD = ISHFTR(ICAMWD,1)
      IE = (JK-J1)*NBIT
      IF(.NOT.TBIT(ICAMWD,31)) GO TO 32
      IE = IE + IBT
C---
C---   GROUP NR IE IS SET, DISPLAY IT
C---
      FI1=(IE-2)*DEFI-DEFIH + EPS
      FI2=IE*DEFI+DEFIH - EPS
      RR=RF(HRF(IE))
      CALL CIRSEG(8,RR,FI1,FI2,0.,0.,0)
   32 CONTINUE
C
C NOW SEPTANCES
C
      NBIT=7
      J3 = IPJH + 20
      HELP(2) = HDATA(J3)
      ICAMWD = ISHFTL(ICAMWD,1)
      DO 33 IBT = 1,NBIT
      ICAMWD = ISHFTR(ICAMWD,1)
      IF(.NOT.TBIT(ICAMWD,31)) GO TO 33
C---
C---   SEPTANCE NR IBT IS SET, DISPLAY IT
C---
      FI1=(IBT-1)*DEFI7-3.5*DEFI + EPS
      FI2=FI1+DEFI7 - 2.*EPS
      CALL CIRSEG(20,R7,FI1,FI2,0.,0.,0)
   33 CONTINUE
C
C OUTLINE LIMITS OF THE SEPTANCES
C
      FISX = -3.5*DEFI
      FISX = FISX - DEFI7
      R2 = OUTR2
      R1 = R7
      DO 28 IIK = 1,7
      FISX = FISX + DEFI7
      X2 = R2*COS(FISX)
      Y2 = R2*SIN(FISX)
      X1 = R1*COS(FISX)
      Y1 = R1*SIN(FISX)
      CALL DRAMOV(-X1,Y1,-X2,Y2,L7)
 28   CONTINUE
C
C DISPLAY ENDCAP QUADRANT BITS
C
7774  CONTINUE
      ISTX = 3695
      IADD = 400
      ISTY = 1250
      XMINRE = XMIN
      XMAXRE = XMAX
      YMINRE = YMIN
      YMAXRE = YMAX
      XXX = XMAX - .05*(XMAX-XMIN)
      YYY=YMIN + 0.42*(YMAX-YMIN)
      CALL MOVEA(XXX,YYY)
      CALL CORE(HMW,4)
      WRITE(cHMW,1125)          ! PMF 17/11/99: UNIT=10 changed to cHMW
1125  FORMAT(' +Z ')
      CALL EOUTST(4,HMW)
      YYY=YMIN + 0.28*(YMAX-YMIN)
      CALL MOVEA(XXX,YYY)
      CALL CORE(HMW,4)
      WRITE(cHMW,1126)          ! PMF 17/11/99: JUSCRN changed to cHMW
1126  FORMAT(' -Z ')
      CALL EOUTST(4,HMW)
      CALL TWINDO (ISTX,ISTX+IADD,ISTY,ISTY+IADD)
      CALL DWINDO(-50.,50.,-50.,50.)
C                             DRAW ECAP CIRCLES AND QUADRANTS
      XV = 0.
      YV = 25.
      CALL PLYGON(NN4,R4,XV,YV,0)
      CALL PLYGON(NN4,R4,XV,-YV,0)
      CALL DRAMOV(XV,YV+R4,XV,YV-R4,0)
      CALL DRAMOV(XV,-YV+R4,XV,-YV-R4,0)
      CALL DRAMOV(XV-R4,YV,XV+R4,YV,0)
      CALL DRAMOV(XV-R4,-YV,XV+R4,-YV,0)
C
      NBIT=8
      J4 = IPJH + 21
      HELP(2) = HDATA(J4)
      ICAMWD = ISHFTL(ICAMWD,1)
      DO 34 IBT = 1,NBIT
      ICAMWD = ISHFTR(ICAMWD,1)
      IF(.NOT.TBIT(ICAMWD,31)) GO TO 34
C---
C---   ECAP QUADRANT NR IBT IS SET, DISPLAY IT
C---
      IQ = IBT
      IF(IQ.GT.4) IQ = IQ - 4
      XV = 0.
      YV = -25.
      IF(IBT.GT.4) YV = 25.
      CALL ECAPQ(10,R4,IQ,XV,YV,0)
   34 CONTINUE
C                 RESET STANDARD VIEW
      CALL TWINDO (0,4095,0,4095)
      CALL SETSCL(LASTVW)
      XMIN = XMINRE
      XMAX = XMAXRE
      YMIN = YMINRE
      YMAX = YMAXRE
      CALL DWINDO (XMIN,XMAX,YMIN,YMAX)
C
C DISPLAY NOW TBG BITS
C
      IPJ=IDATA(IBLN('TRIG'))
      IF(IPJ.GT.0) GO TO 4740
      WRITE(6,475)
475   FORMAT(' NO TRIG BANK IN THIS EVENT..')
      RETURN
4740  IBN=IDATA(IPJ+1)
      IF(LAND(IBN,MASK2).NE.0) GO TO 4
      WRITE(6,476) IBN
476   FORMAT(' BANK DESCRIPTOR NOT EQUAL 2, BUT ',I6,' DISPLAY NOT POSSI
     $BLE')
      RETURN
 4    IPJH = 2*IPJ
      IF(LASTVW.GT.3) GO TO 7775
      J1 = IPJH + 5
      J2 = IPJH + 7
C
C LOOP OVER THE TBG BITS
C
      NBIT=15
      DO 62 JK = J1,J2
      HELP(2) = HDATA(JK)
      ICAMWD = ISHFTL(ICAMWD,1)
      IE = (JK-J1)*(NBIT-1)
      DO 62 IBT = 1,NBIT
      ICAMWD = ISHFTR(ICAMWD,1)
      IF(IBT.EQ.8) GO TO 62
      IF(.NOT.TBIT(ICAMWD,31)) GO TO 62
      JBT = IBT
      IF(JBT.GT.7) JBT = JBT - 1
      IF = IE + JBT
C---
C---   TBGBIT NR IF IS SET, DISPLAY IT
C---
      FI1=(IF-1)*DEFI
      RR=RF(HRF(IF))
      CALL TBGSTR(RR,FI1,0.,0.,0)
   62 CONTINUE
7775  RETURN
      END
      SUBROUTINE TBGSTR(R,FI1,XV,YV,L)
      COMMON /CJTRIG/ PI,TWOPI
C
C     DRAW SYMBOL AT RADIUS R, ANGLE FI1  CENTERED AT XV,YV
C     L GIVES CODE FOR SYMBOL
C
      X0 = R*COS(FI1)
      Y0 = R*SIN(FI1)
      CALL PLYGON(6,15.,-XV-X0,YV+Y0,0)
      RETURN
      END
      SUBROUTINE CIRSEG(NN,R,FI1,FI2,XV,YV,L)
      COMMON /CJTRIG/ PI,TWOPI
C
C     DRAW CIRCLE SEGMENT AT RADIUS R, BETWEEN FI1,2  CENTERED AT XV,YV
C     NN GIVES SEGMENTATION OF SEGMENT
C     L GIVES CODE FOR HASHED LINE, 0 GIVES FULL DRAW
C
      X0 = R*COS(FI1)
      Y0 = R*SIN(FI1)
      CALL MOVEA(-X0,Y0)
      DEFI = ABS(FI2-FI1)/FLOAT(NN)
      FISX = FI1
      DO 27 IIK = 1,NN
      FISX = FISX + DEFI
      X0 = R*COS(FISX)
      Y0 = R*SIN(FISX)
      IF(L.GT.0) CALL DASHA(XV-X0,YV+Y0,L)
 27   IF(L.LE.0) CALL DRAWA(XV-X0,YV+Y0)
      RETURN
      END
      SUBROUTINE ECAPQ(NN,R,IQ,XV,YV,L)
C
C     FILL QUADRANT IQ WITH LINE MESH, IN THE CIRCLE R AROUND XV,YV
C     NN GIVES SEGMENTATION OF LINE MESH
C     L GIVES CODE FOR HASHED LINE, 0 GIVES FULL DRAW
C
      DELRX = R/FLOAT(NN)
      IF(IQ.EQ.1.OR.IQ.EQ.4) DELRX = - DELRX
      X1 = XV
      NNL = NN-1
      DO 2  I = 1,NNL
      X1 = X1 + DELRX
      CALL MOVEA(X1,YV)
      DY = SQRT(R*R - (XV-X1)**2)
      Y1 = YV+DY
      IF(IQ.EQ.3.OR.IQ.EQ.4) Y1 = YV - DY
      CALL DRAWA(X1,Y1)
2     CONTINUE
      RETURN
      END
