C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
SUBROUTINE LATTIC
< (RX,RY,RZ,RR,IRX,IRY,IRZ)
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
IMPLICIT REAL(A-H,O-Y)
IMPLICIT COMPLEX(Z)
INCLUDE 'PACVPP'
REAL RX(125),RY(125),RZ(125),RR(125)
INTEGER IRX(125),IRY(125),IRZ(125)
NEIBR = 2
NEIBRD = 125
C
ALEN1=SQRT(ALTV(1,1)**2+ALTV(2,1)**2+ALTV(3,1)**2)
ALEN2=SQRT(ALTV(1,2)**2+ALTV(2,2)**2+ALTV(3,2)**2)
ALEN3=SQRT(ALTV(1,3)**2+ALTV(2,3)**2+ALTV(3,3)**2)
ALMAX=MAX(ALEN1,ALEN2,ALEN3)
ALF=1.0D0/ALMAX
WRITE(6,*) ' <<>>'
FFF= ALTV(1,1)*(ALTV(2,2)*ALTV(3,3)-ALTV(3,2)*ALTV(2,3))
& + ALTV(2,1)*(ALTV(3,2)*ALTV(1,3)-ALTV(1,2)*ALTV(3,3))
& + ALTV(3,1)*(ALTV(1,2)*ALTV(2,3)-ALTV(2,2)*ALTV(1,3))
UNIVOL=ABS( FFF )
WRITE(6,708) UNIVOL
708 FORMAT(1H ,'VOLUME OF A UNIT CELL=',F15.6)
FFF=2.D0*PAI/FFF
RLTV(1,1)=(ALTV(2,2)*ALTV(3,3)-ALTV(3,2)*ALTV(2,3))*FFF
RLTV(2,1)=(ALTV(3,2)*ALTV(1,3)-ALTV(1,2)*ALTV(3,3))*FFF
RLTV(3,1)=(ALTV(1,2)*ALTV(2,3)-ALTV(2,2)*ALTV(1,3))*FFF
RLTV(1,2)=(ALTV(2,3)*ALTV(3,1)-ALTV(3,3)*ALTV(2,1))*FFF
RLTV(2,2)=(ALTV(3,3)*ALTV(1,1)-ALTV(1,3)*ALTV(3,1))*FFF
RLTV(3,2)=(ALTV(1,3)*ALTV(2,1)-ALTV(2,3)*ALTV(1,1))*FFF
RLTV(1,3)=(ALTV(2,1)*ALTV(3,2)-ALTV(3,1)*ALTV(2,2))*FFF
RLTV(2,3)=(ALTV(3,1)*ALTV(1,2)-ALTV(1,1)*ALTV(3,2))*FFF
RLTV(3,3)=(ALTV(1,1)*ALTV(2,2)-ALTV(2,1)*ALTV(1,2))*FFF
WRITE(6,707) ((RLTV(I,J),I=1,3),J=1,3)
707 FORMAT((1H ,3(F10.6,5X)))
DO 800 I=1,3
DO 810 J=1,3
ALINV(I,J)=RLTV(J,I)/(2.D0*PAI)
810 CONTINUE
800 CONTINUE
DO 703 I=1,3
DO 703 J=1,3
FFF = ALTV(I,1)*ALINV(1,J) + ALTV(I,2)*ALINV(2,J)
& + ALTV(I,3)*ALINV(3,J)
WRITE(6,702) I,J,FFF
702 FORMAT(1H ,'ALTV(',I3,')*ALINV(',I3,')=',F20.15)
703 CONTINUE
C--*--GENERATE TRANSLATIONAL VECTOR
MM=0
DO 500 I=-NEIBR,NEIBR
DO 510 J=-NEIBR,NEIBR
DO 520 K=-NEIBR,NEIBR
MM = MM + 1
IRX(MM) = I
IRY(MM) = I
IRZ(MM) = I
F1 = DFLOAT(I)
F2 = DFLOAT(J)
F3 = DFLOAT(K)
RX(MM) = ALTV(1,1)*F1 + ALTV(1,2)*F2 + ALTV(1,3)*F3
RY(MM) = ALTV(2,1)*F1 + ALTV(2,2)*F2 + ALTV(2,3)*F3
RZ(MM) = ALTV(3,1)*F1 + ALTV(3,2)*F2 + ALTV(3,3)*F3
RR(MM) = SQRT( RX(MM)**2 + RY(MM)**2 + RZ(MM)**2 )
520 CONTINUE
510 CONTINUE
500 CONTINUE
IF(MM.NE.NEIBRD) THEN
WRITE(6,*) ' MM.NE.NEIBRD MM,NEIBRD =',MM,NEIBRD
END IF
CALL HPSORT(NEIBRD,IRX,IRY,IRZ,RX,RY,RZ,RR)
IF(IPRI.GE.2) THEN
WRITE(6,*) ' TRANSLATIONAL VECTOR'
WRITE(6,600) (I,IRX(I),IRY(I),IRZ(I),
& RX(I) ,RY(I) ,RZ(I) ,RR(I),I=1,NEIBRD)
END IF
600 FORMAT((' ',4I5,4F12.6))
WRITE (6,*) 'UNIVOL(IN LATTIC) = ',UNIVOL
RETURN
END