C---*----1----*----2----*----3----*----4----*----5----*----6----*----7
SUBROUTINE SYMM(KOPR,NOPR,NBZTYP,NEIBRD,NFOUT,RX,RY,RZ)
IMPLICIT REAL(A-H,O-Y)
IMPLICIT COMPLEX(Z)
INCLUDE 'PACVPP'
DIMENSION NPPP(KNG,KO),NAAA(KATM,KO)
DIMENSION OO(3,3,KO),TAA(3,KO)
DIMENSION RX(NEIBRD),RY(NEIBRD),RZ(NEIBRD)
!XOCL SUBPROCESSOR PT(IPARA)=PQ(1:IPARA)
!XOCL INDEX PARTITION IQ=(PT,INDEX=1:KO,PART=BAND)
!XOCL LOCAL NPPP(:,/IQ),NAAA(:,/IQ),OO(:,:,/IQ),TAA(:,/IQ)
EQUIVALENCE (NGPT,NPPP),(NAPT,NAAA),(OP,OO),(TAU,TAA)
C----------------------------------------------------------------------
IF (NBZTYP.EQ.5) THEN
A = ABS(ALTV(1,1))*2.D0
ELSE IF(NBZTYP.EQ.6.OR.NBZTYP.EQ.7) THEN
A = ABS(ALTV(1,1))
B = ABS(ALTV(2,2))
ELSE IF(NBZTYP.EQ.8 .OR. NBZTYP.EQ.10) THEN
A = ABS(ALTV(1,1))
B = ABS(ALTV(3,3))
ELSE IF(NBZTYP.EQ.9.OR.NBZTYP.GE.11) THEN
A = ABS(ALTV(1,1))
B = ABS(ALTV(2,2))
C = ABS(ALTV(3,3))
END IF
C---------------------------------------------
CALL OPGR
> (NBZTYP,KOPR,A,B,C,NFOUT,
< NOPR)
C--*--SYMMETRY PAIRS FOR G-POINTS ------------
DO 100 I = 1,KG
PX=GX(I)
PY=GY(I)
PZ=GZ(I)
!XOCL SPREAD DO /IQ
DO 110 NO=1,NOPR
FX=OO(1,1,NO)*PX +OO(1,2,NO)*PY +OO(1,3,NO)*PZ
FY=OO(2,1,NO)*PX +OO(2,2,NO)*PY +OO(2,3,NO)*PZ
FZ=OO(3,1,NO)*PX +OO(3,2,NO)*PY +OO(3,3,NO)*PZ
DO 120 J = 1,KG
FF1 = ABS(GX(J)-FX)+ABS(GY(J)-FY)+ABS(GZ(J)-FZ)
IF (FF1.LE.1.D-5) THEN
NPPP(I,NO) = J
GOTO 110
END IF
120 CONTINUE
WRITE(NFOUT,130) I,NO
STOP
110 CONTINUE
!XOCL END SPREAD
100 CONTINUE
130 FORMAT(' ','THERE IS NO PAIR FOR NG,NOP=',2I8)
C--*--SYMMETRY PAIRS FOR ATOMS
DDD = 1.0D-5
DO 200 I = 1,KATM
PX=CATX(I)
PY=CATY(I)
PZ=CATZ(I)
!XOCL SPREAD DO /IQ
DO 210 NO=1,NOPR
FX=OO(1,1,NO)*PX+OO(1,2,NO)*PY+OO(1,3,NO)*PZ+TAA(1,NO)
FY=OO(2,1,NO)*PX+OO(2,2,NO)*PY+OO(2,3,NO)*PZ+TAA(2,NO)
FZ=OO(3,1,NO)*PX+OO(3,2,NO)*PY+OO(3,3,NO)*PZ+TAA(3,NO)
DO 220 J = 1,KATM
DO 230 K = 1,NEIBRD
FFX = ABS( FX - CATX(J) - RX(K) )
FFY = ABS( FY - CATY(J) - RY(K) )
FFZ = ABS( FZ - CATZ(J) - RZ(K) )
IF( (FFX.LE.DDD).AND.
& (FFY.LE.DDD).AND.
& (FFZ.LE.DDD) ) THEN
NAAA(I,NO) = J
GOTO 210
END IF
230 CONTINUE
220 CONTINUE
WRITE(NFOUT,*) ' NO PAIR I, NO ',I,NO
STOP
210 CONTINUE
!XOCL END SPREAD
200 CONTINUE
C--*--OUTPUT
IF(IPRI.GE.2) THEN
WRITE(NFOUT,*) ' NGPT '
DO 310 I=1,20
WRITE(NFOUT,*) ' NG =',I
WRITE(NFOUT,300) (NGPT(I,J),J=1,NOPR)
310 CONTINUE
DO 320 I=KG-20,KG
WRITE(NFOUT,*) ' NG =',I
WRITE(NFOUT,300) (NGPT(I,J),J=1,NOPR)
320 CONTINUE
WRITE(NFOUT,*) ' NAPT '
DO 330 I=1,KATM
WRITE(NFOUT,*) ' NA =',I
WRITE(NFOUT,300) (NAPT(I,J),J=1,NOPR)
330 CONTINUE
300 FORMAT((8I8))
END IF
RETURN
END