C     DINT REVISED TO GIVE DRILLING COORDINATES
C     DISTANCE PROGRAM
C     DATA CARD 1 - TITLE CARD, 72 HOLLERITH SYMBOLS
C     DATA CARD 2A- CELL DIMENSIONS -6F10.5- A,B,C,ALPHA,BETA,GAMMA
C     DATA CARD 2B- STANDARD DEVIATIONS OF THE CELL DIMENSIONS. (6F10.5)
C                   SIGA,SIGB,SIGC,SIGALF,SIGBET,SIGGAM
C     DATA CARD 3 - 3I5,2F5.2, 4I5
C                 NEQUIV = NO. OF EQUIVALENT POSITION CARDS
C                 NATOM  = NO. OF ATOMS
C                 NANG = 0 NO ANGLE CALCULATION
C                      = 1 CALCULATE ANGLES
C                 DMAX   = MAXIMUM DISTANCE TO CALCULATE TO.
C                 ANGMAX = MAXIMUM BOND DISTANCE FOR ANGLE CALCULATION.
C                 NCENT  = 0  NO CENTER OF SYMMETRY
C                        = 1  CENTER OF SYMMETRY
C                 NTEMP = 0 NO TEMP. FACTOR EFFECT ON BOND CALCULATIONS.
C                       = 1 CALCULATE TEMPERATURE EFFECTS.
C                 NSDANG = 0 NO CALC. OF S.D. OF ANGLES
C                        = 1 CALCULATE S.D. OF ANGLES
C                 NEI = INDICATOR FOR LATTICE TYPE
C                       NEI=0 PRIMITIVE(NO CONDITIONS)
C                       NEI=1 A-CENTERED(K+L=2N)
C                       NEI=2 B-CENTERED(H+L=2N)
C                       NEI=3 C-CENTERED(H+L=2N)
C                       NEI=4 F-CENTERED(H+K=2N, H+L=2N, K+L=2N)
C                       NEI=5 I-CENTERED(H+K+L=2N)
C                       NEI=6 R-OBVERSE(-H+K+L=3N)
C                       NEI=7 R-REVERSE(H-K+L=3N)
C                       NEI=8 ERROR
C                       NEI=9 PRIMITIVE(NO CONDITIONS)
C                 IDRILL = 0 NO DRILLING COORDINATES OUTPUT
C                          1 DRILLING COORDINATES AS PHI(RH) AND PHI(LH)
C                            LISTED FOR SMITHS DRILL, REVERSE RH AND LH
C                            FOR NEWNHAMS DRILL
C                            TABLE OF ATOMIC POSITIONS FOR 1 UNIT CELL
C                            LISTED FOR FRACTIONAL,CRYSTAL SPACE, AND
C                            ORTHOGONAL PROJECTION
C                 ITRANS = 0 IF IDRILL=1, USE DEFUALT VALUES FOR
C                            VERTICAL AXIS OF ORTHOGONAL PROJECTION
C                            C VERTICAL, EXCEPT B VERTICAL IN MONOCLINIC
C                          1 A VERTICAL
C                          2 B VERTICAL
C                          3 C VERTICAL
C     DATA CARD 4 - NEQUIV CARDS
C                 FORMAT IS 72A1
C                 COPY VERBATIM FROM INTERNATIONAL TABLES THE EQUIVALENT
C                 POSITIONS (I.E.  X,Y,Z OR X-Y,1/2+Y,-Z)
C                 ONE POSITION PER CARD.
C                 IF NCENT = 1, OMIT THE CENTRIC EQUIVALENT POSITIONS.
C     DATA CARD 5 -NATOM CARDS-ONE FOR EACH ATOM.-A6,12X,5F9.6,I2-
C                  X,Y,Z,B,G,I,ATOM
C                  IF B=0 BETA CARD (6F9.6) FOLLOWS IMMEDIATELY
C                  AT PRESENT G AND I ARE UNNECESSARY
C                 (ATOM IS A HOLLERITH DESIGNATION OF THE ATOMS FOR
C                  CONVENIENCE IN LABELLING THE ATOM TYPE IN THE PRINT
C                 OUT.)
C     DATA CARD 6 -NATOM CARDS-ONE FOR EACH ATOM.  STANDARD DEVIATIONS.
C                 3F10.8       SIGX,SIGY,SIGZ
C     DATA CARD 7 -SIGNAL CARD - I1
C                  NEWDAT = 0 TERMINATE PROGRAM
C                           1 NEW DATA SET FOLLOWS
	 IMPLICIT REAL*8 (A-H,O-Z)
	LOGICAL*1 TITLE,CHAR
	DIMENSION TITLE(72),CHAR(72)
C
C     THIS PROGRAM WILL ACCEPT UP TO 100 ATOMS AND ALL SPACE GROUPS
C        WITH 48 OR LESS EQUIVALENT POSITIONS (I.E. ALL EXCEPT A FEW
C        CUBIC WITH 96 OR 192 EQUIVALENT POSITIONS)
C     THIS LIMIT IS BASED ON MACHINE SIZE
C     TO CALCULATE THESE ADDITIONAL SPACE GROUPS REPLACE THE FOLLOWING
C        CARDS WITH THOSE COMMENTED IMMEDIATELY AFTER
C     SIMILAR COMMENTED DIMENSION STATEMENTS ARE INCLUDED IN DISLIS,
C        NEISR,ADDEP, AND DERDIS
C
C     DIMENSION RN(48,3),RD(3),S1(48,3),S2(48,3),S3(48,3)
C     DIMENSION ATOM(100),BISO(100),G(100),ITBL(100),B11(100),B22(100),
C    1B33(100),B12(100),B13(100),B23(100),NDIST(100),SIGX(100),
C    2SIGY(100),SIGZ(100),USQAVE(100)
C     DIMENSION X(100,48),Y(100,48),Z(100,48)
	DIMENSION RN(192,3),RD(3),S1(192,3),S2(192,3),S3(192,3)
	DIMENSION ATOM(40),BISO(40),G(40),ITBL(40),B11(40),B22(40),
	1B33(40),B12(40),B13(40),B23(40),NDIST(40),SIGX(40),SIGY(40),
	2SIGZ(40),USQAVE(40)
	DIMENSION X(40,192),Y(40,192),Z(40,192)
	DIMENSION X1(50),Y1(50),Z1(50),D(50),DS12U2(50),DS12V2(50),DS12W2(
	150),DS12U1(50),DS12V1(50),DS12W1(50),DS12DA(50),DS12DB(50),DS12DC(
	150),DS12AL(50),DS12BE(50),DS12GA(50),MJ(50),ML(50),MI(50)
	DIMENSION XP(27),YP(27),ZP(27),T(3,3),R(3,3),BT(3,3),PROD(3,3),UMA
	1T(3,3),RNX(3),RDX(3),S1X(3),S2X(3),S3X(3),Q(3,3),DPHIC(9)
	COMMON/CELLS/A,B,C,COSA,COSB,COSC,SINA,SINB,SINC,ASTAR,BSTAR,CSTAR
	1,COSAST,COSBST,COSCST,SINAST,SINBST,SINCST,NSYM
	COMMON/DISDER/S1,S2,S3,SIGX,SIGY,SIGZ,DLDX1,DLDX2,DLDY1,DLDY2,DLDZ
	11,DLDZ2
	COMMON/PARDER/SIGA,SIGB,SIGC,SIGALF,SIGBET,SIGGAM,DLDA,DLDB,DLDC,D
	1LDAL,DLDBE,DLDGA,DX,DY,DZ
	COMMON/DLDVV/ASQARE,BSQARE,CSQARE,ABCOSC,ACCOSB,BCCOSA,DELX,DELY,D
	1ELZ,DIST
	COMMON/LISDIS/ATOM,D,R,X1,Y1,Z1,X,Y,Z,T,NBLANK,III,NDIST,NATOM,IDR
	1ILL,ITRANS,NEQUIV
	COMMON/IDX/ BTOM(100)
	II=5
	III=6
	NBLANK=8
168	REWIND NBLANK
	READ (II,163) TITLE
	WRITE (III,141) TITLE
	DO 169 N=1,3
169	READ(II,170)
170	FORMAT (1H )
C
C     READ AND PROCESS CELL PARAMETERS
C
	READ (II,171) A,B,C,ALPHA,SEC4,BETA,SEC5,GAMMA,SEC6
171	FORMAT (3F10.5,3(F7.3,F3.0))
	ALPHA=ALPHA+SEC4/60.0
	BETA=BETA+SEC5/60.0
	GAMMA=GAMMA+SEC6/60.0
	READ (II,148) SIGA,SIGB,SIGC,SIGALF,SIGBET,SIGGAM
	PI=3.1415926536D0
	PISQX2=2.0D0*PI*PI
	RAD=180.D0/PI
	COSA=DCOS(PI*ALPHA/180.D0)
	COSB=DCOS(PI*BETA/180.D0)
	COSC=DCOS(PI*GAMMA/180.D0)
	SINA=DSQRT(1.D0-COSA*COSA)
	SINB=DSQRT(1.D0-COSB*COSB)
	SINC=DSQRT(1.D0-COSC*COSC)
	V=A*B*C*DSQRT(1.D0-COSA*COSA-COSB*COSB-COSC*COSC+2.D0*COSA*COSB*CO
	1SC)
	ASTAR=B*C*SINA/V
	BSTAR=A*C*SINB/V
	CSTAR=A*B*SINC/V
	COSAST=(COSB*COSC-COSA)/(SINB*SINC)
	COSBST=(COSA*COSC-COSB)/(SINA*SINC)
	COSCST=(COSA*COSB-COSC)/(SINA*SINB)
	Q(2,3)=COSAST*2.0D0
	Q(1,3)=COSBST*2.0D0
	Q(1,2)=COSCST*2.0D0
	DO 3 I=1,3
3	Q(I,I)=1.0D0
	SINAST=DSQRT(1.D0-COSAST**2)
	SINBST=DSQRT(1.D0-COSBST**2)
	SINCST=DSQRT(1.D0-COSCST**2)
	ALPHST=(DATAN(SINAST/COSAST))*(180.D0/PI)
	BETAST=(DATAN(SINBST/COSBST))*(180.D0/PI)
	GAMMST=(DATAN(SINCST/COSCST))*(180.D0/PI)
	ABCOSC=A*B*COSC
	ACCOSB=A*C*COSB
	BCCOSA=B*C*COSA
	ASQARE=A*A
	BSQARE=B*B
	CSQARE=C*C
C
C     THE FOLLOWING IS THE MATRIX THAT TRANSFORMS A,B,C TO AN ORTHOGONAL
C             SET I,J,K.
C     TRANSPOSE OF R = T.
C
	R(1,1)=A
	R(1,2)=0.0D0
	R(1,3)=0.0D0
	R(2,1)=(-1.0D0/BSTAR)*(C*CSTAR*COSAST*COSB+A*ASTAR*COSCST)
	R(2,2)=-(C*CSTAR*COSAST*SINB/BSTAR)
	R(2,3)=1.0D0/BSTAR
	R(3,1)=C*COSB
	R(3,2)=C*SINB
	R(3,3)=0.0D0
	CALL MATRAN(R,T)
C
	WRITE (III,149) A,SIGA,B,SIGB,C,SIGC,ALPHA,SIGALF,BETA,SIGBET,GAMM
	1A,SIGGAM,COSA,COSB,COSC,SINA,SINB,SINC,V
	WRITE (III,159) ASTAR,BSTAR,CSTAR,ALPHST,BETAST,GAMMST,COSAST,COSB
	1ST,COSCST,SINAST,SINBST,SINCST
	SIGALF=(SIGALF/180.D0)*PI
	SIGBET=(SIGBET/180.D0)*PI
	SIGGAM=(SIGGAM/180.D0)*PI
C
C     READ AND INITIALIZE CONTROL PARAMETERS
C
	READ (II,142) NEQUIV,NATOM,NANG,DMAX,ANGMAX,NCENT,NTEMP,NSDANG,NEI
	1,IDRILL,ITRANS
	WRITE (III,142) NEQUIV,NATOM,NANG,DMAX,ANGMAX,NCENT,NTEMP,NSDANG,N
	1EI,IDRILL,ITRANS
142	FORMAT (3I5,2F5.2,6I5)
C     NSYM = 1     TRICLINIC
C            2     MONOCLINIC
C            3     ORTHORHOMBIC
C            4     HEXAGONAL
C            5     RHOMBOHEDRAL
C            6     TETRAGONAL
C            7     CUBIC
	NSYM=1
	IF (A-B)  4,9,4
4	IF (ALPHA-90.D0)  14,5,14
5	IF (GAMMA-90.D0)  14,6,14
6	IF (BETA-90.D0)  8,7,8
7	NSYM=NSYM+1
8	NSYM=NSYM+1
	GO TO 14
9	NSYM=NSYM+3
	IF (GAMMA-90.D0)  10,12,10
10	IF (BETA-90.D0)  11,14,11
11	NSYM=NSYM+1
	GO TO 14
12	NSYM=NSYM+2
	IF (A-C)  14,13,14
13	NSYM=NSYM+1
14	IF (DMAX)  16,15,16
15	DMAX=4.0D0
16	IF (ANGMAX)  18,17,18
17	ANGMAX=DMAX
18	DXMAX=DMAX*ASTAR*A
	DYMAX=DMAX*BSTAR*B
	DZMAX=DMAX*CSTAR*C
	DMAXSQ=DMAX*DMAX
C
C     READ SYMMETRY CARDS AND GENERATE EQUIVALENT POSITIONS
C
	NEQU=NEQUIV
	DO 28 I=1,NEQU
	READ (II,163) CHAR
	WRITE (III,164) CHAR
	CALL TRANSL(CHAR,RNX,RDX,S1X,S2X,S3X)
	DO 20 J=1,3
	RN(I,J)=RNX(J)
	RD(J)=RDX(J)
	S1(I,J)=S1X(J)
	S2(I,J)=S2X(J)
20	S3(I,J)=S3X(J)
	WRITE (III,144) (RN(I,J),RD(J),S1(I,J),S2(I,J),S3(I,J),J=1,3)
	IF (NCENT)  22,24,22
22	L=I+NEQUIV
	DO 23 J=1,3
	RN(L,J)=RN(I,J)
	S1(L,J)=-S1(I,J)
	S2(L,J)=-S2(I,J)
23	S3(L,J)=-S3(I,J)
	WRITE (III,144) (RN(L,J),RD(J),S1(L,J),S2(L,J),S3(L,J),J=1,3)
24	DO 27 J=1,3
	IF (RD(J))  25,27,25
25	RN(I,J)=RN(I,J)/RD(J)
	IF (NCENT)  26,27,26
26	RN(L,J)=RN(L,J)/RD(J)
27	CONTINUE
	CALL NEISR(I,RN,S1,S2,S3,NEQUIV,NCENT,NEI)
28	CONTINUE
	IF (NCENT)  29,30,29
29	NEQUIV=2*NEQUIV
30	WRITE (III,143) NEQUIV,NATOM,DMAX,DXMAX,DYMAX,DZMAX
	WRITE (III,145)
C
C     READ ATOMIC PARAMETERS
C
	   DO 262 I=1,NATOM
	READ (II,146) ATOM(I),XXX,YYY,ZZZ,BISO(I),G(I),ITBL(I)
	WRITE (III,166) ATOM(I),XXX,YYY,ZZZ,BISO(I)
	BTOM(I) = ATOM(I)
	IF (BISO(I))  33,32,33
32	READ (II,147) B11(I),B22(I),B33(I),B12(I),B13(I),B23(I)
	WRITE (III,147) B11(I),B22(I),B33(I),B12(I),B13(I),B23(I)
	B11(I)=B11(I)*ASTAR*ASTAR/4.0D0
	B22(I)=B22(I)*BSTAR*BSTAR/4.0D0
	B33(I)=B33(I)*CSTAR*CSTAR/4.0D0
	B12(I)=B12(I)*ASTAR*BSTAR/4.0D0
	B13(I)=B13(I)*ASTAR*CSTAR/4.0D0
	B23(I)=B23(I)*BSTAR*CSTAR/4.0D0
	WRITE (III,147) B11(I),B22(I),B33(I),B12(I),B13(I),B23(I)
	B12(I)=B12(I)*2.0D0
	B13(I)=B13(I)*2.0D0
	B23(I)=B23(I)*2.0D0
33	IF (NTEMP)  34,40,34
34	IF (BISO(I))  36,35,37
35	BT(1,1)=B11(I)
	BT(2,2)=B22(I)
	BT(3,3)=B33(I)
	BT(1,3)=B13(I)/2.0D0
	BT(1,2)=B12(I)/2.0D0
	BT(2,3)=B23(I)/2.0D0
	BT(2,1)=BT(1,2)
	BT(3,1)=BT(1,3)
	BT(3,2)=BT(2,3)
	IF (MATTST(BT))  36,38,38
36	WRITE (III,161) ATOM(I)
	USQAVE(I)=-100.D0
	GO TO 40
37	USQAVE(I)=3.0D0*BISO(I)/(4.0D0*PISQX2)
	GO TO 39
C
C     CALCULATE THE VALUE OF THE TRACE OF ATOM(I) USQ = TXBXR/2*PI*PI
C
38	CALL MATMUL(BT,R,PROD)
	CALL MATMUL(T,PROD,UMAT)
	USQAVE(I)=(UMAT(1,1)+UMAT(2,2)+UMAT(3,3))/PISQX2
39	UBAR=DSQRT(USQAVE(I)/3.0D0)
	WRITE (III,162) ATOM(I),UBAR
C
C     GENERATE X Y Z LIST FOR EACH ATOM
C
40	DO 62 J=1,NEQUIV
	XXXX=RN(J,1)+S1(J,1)*XXX+S2(J,1)*YYY+S3(J,1)*ZZZ
	YYYY=RN(J,2)+S1(J,2)*XXX+S2(J,2)*YYY+S3(J,2)*ZZZ
	ZZZZ=RN(J,3)+S1(J,3)*XXX+S2(J,3)*YYY+S3(J,3)*ZZZ
	IF (XXXX)  42,43,43
42	XXXX=1.0D0+XXXX
43	IF (YYYY)  44,45,45
44	YYYY=1.0D0+YYYY
45	IF (ZZZZ)  46,47,47
46	ZZZZ=1.0D0+ZZZZ
47	IF (XXXX-1.0D0)  49,48,48
48	XXXX=XXXX-1.0D0
49	IF (YYYY-1.0D0)  51,50,50
50	YYYY=YYYY-1.0D0
51	IF (ZZZZ-1.0D0)  53,52,52
52	ZZZZ=ZZZZ-1.0D0
53	M=J-1
	IF (M)  60,60,55
55	DO 59 L=1,M
	IF ((DABS(XXXX-X(I,L))-.00001D0))  57,57,59
57	IF ((DABS(YYYY-Y(I,L))-.00001D0))  58,58,59
58	IF ((DABS(ZZZZ-Z(I,L))-.00001D0))  61,61,59
59	CONTINUE
60	X(I,J)=XXXX
	Y(I,J)=YYYY
	Z(I,J)=ZZZZ
	GO TO 62
61	X(I,J)=100.D0
62	CONTINUE
262	CONTINUE
	DO 63 I=1,NATOM
	READ (II,153) SIGX(I),SIGY(I),SIGZ(I)
63	WRITE (III,1530)SIGX(I),SIGY(I),SIGZ(I)
1530	FORMAT (1X,3F10.8)
	WRITE (III,160)
	WRITE (III,158)
	K=0
	   DO 201 L=1,NATOM
	WRITE (III,151)
	NDIST(L)=0
	M=1
	XXXX=X(L,1)+1.0D0
	YYYY=Y(L,1)+1.0D0
	ZZZZ=Z(L,1)+1.0D0
	   DO 202 I=1,NATOM
	DO 100 J=1,NEQUIV
	IF (X(I,J)-100.D0)  67,100,67
67	KK=0
	DO 68 LL=1,3
	U=LL-1
	DO 68 MM=1,3
	S=MM-1
	DO 68 NN=1,3
	W=NN-1
	KK=KK+1
	XP(KK)=X(I,J)+U
	YP(KK)=Y(I,J)+S
68	ZP(KK)=Z(I,J)+W
69	K=K+1
	IF (K-27)  71,71,100
71	DELX=XP(K)-XXXX
	DX=DELX*A
	DD=DABS(DX)
	IF (DXMAX-DD)  98,73,73
73	DELY=YP(K)-YYYY
	DY=DELY*B
	DD=DABS(DY)
	IF (DYMAX-DD)  99,75,75
75	DELZ=ZP(K)-ZZZZ
	DZ=DELZ*C
	DD=DABS(DZ)
	IF (DZMAX-DD)  69,77,77
77	DISTSQ=DX*DX+DY*DY+DZ*DZ+2.D0*DY*DZ*COSA+2.D0*DX*DZ*COSB+2.D0*DX*D
	1Y*COSC
	IF (DISTSQ-0.000001D0)  69,69,79
79	IF (DISTSQ-DMAXSQ)  80,80,69
80	DIST=DSQRT(DISTSQ)
	CALL DERPAR
	SIGSQ=DLDA**2+DLDB**2+DLDC**2+DLDAL**2+DLDBE**2+DLDGA**2
	KKK=1
	CALL DERDIS(KKK,J,L,I,XXXX,YYYY,ZZZZ,X(I,1),Y(I,1),Z(I,1))
	SIGSQ=SIGSQ+DLDX2**2+DLDX1**2+DLDY2**2+DLDY1**2+DLDZ2**2+DLDZ1**2
	SIGSQ=SIGSQ+2.D0*DLDX1*DLDY1*COSCST+2.D0*DLDX1*DLDZ1*COSBST+2.D0*D
	1LDY1*DLDZ1*COSAST+2.D0*DLDX2*DLDY2*COSCST+2.D0*DLDX2*DLDZ2*COSBST+
	12.D0*DLDY2*DLDZ2*COSAST
	SD=DSQRT(SIGSQ)
	IF (NTEMP)  83,97,83
83	IF (USQAVE(I))  85,84,84
84	IF (USQAVE(L))  85,86,86
85	DIST12=0.0D0
	DIST21=0.D0
	DISTIN=0.D0
	GO TO 97
86	IF (J-1)  85,87,85
87	DLDX=(DX+DZ*COSB+DY*COSC)*A/DIST
	DLDY=(DY+DZ*COSA+DX*COSC)*B/DIST
	DLDZ=(DZ+DY*COSA+DX*COSB)*C/DIST
	IF (BISO(I))  88,89,88
88	UDIFF1=2.0D0*USQAVE(I)/3.0D0
	GO TO 90
89	UBOND1=(DLDX*DLDX*B11(I)+DLDY*DLDY*B22(I)+DLDZ*DLDZ*B33(I)+DLDX*DL
	1DY*B12(I)+DLDX*DLDZ*B13(I)+DLDY*DLDZ*B23(I))/PISQX2
	UDIFF1=USQAVE(I)-UBOND1
90	IF (BISO(L))  91,92,91
91	UDIFF2=2.0D0*USQAVE(L)/3.0D0
	GO TO 93
92	UBOND2=(DLDX*DLDX*B11(L)+DLDY*DLDY*B22(L)+DLDZ*DLDZ*B33(L)+DLDX*DL
	1DY*B12(L)+DLDX*DLDZ*B13(L)+DLDY*DLDZ*B23(L))/PISQX2
	UDIFF2=USQAVE(L)-UBOND2
93	TWODIS=2.0D0*DIST
	DDIFF=UDIFF2-UDIFF1
	IF (DDIFF)  95,94,94
94	DIST21=DIST+DDIFF/TWODIS
	DIST12=0.D0
	GO TO 96
95	DIST12=DIST-DDIFF/TWODIS
	DIST21=0.0D0
96	DISTIN=DIST+(UDIFF1+UDIFF2)/TWODIS
97	WRITE (NBLANK)ATOM(I),ATOM(L),XP(K),YP(K),ZP(K),XXXX,YYYY,ZZZZ,DIS
	1T,DLDX2,DLDY2,DLDZ2,DLDX1,DLDY1,DLDZ1,DLDA,DLDB,DLDC,DLDAL,DLDBE,D
	1LDGA,SD,ITBL(I),ITBL(L),J,L,I
	NDIST(L)=NDIST(L)+1
	X1D=XP(K)-1.0D0
	Y1D=YP(K)-1.0D0
	Z1D=ZP(K)-1.0D0
	X2D=XXXX-1.0D0
	Y2D=YYYY-1.0D0
	Z2D=ZZZZ-1.0D0
	WRITE (III,150) ATOM(I),ATOM(L),X1D,Y1D,Z1D,X2D,Y2D,Z2D,DIST,SD,DI
	1ST21,DIST12,DISTIN
	GO TO 69
98	K=K+8
	GO TO 69
99	K=K+2
	GO TO 69
100	K=0
202	CONTINUE
201	CONTINUE
	REWIND NBLANK
	IF (NANG)  101,137,101
101	WRITE (III,155)
	WRITE (III,156)
	DO 136 LLL=1,NATOM
	N=NDIST(LLL)
	IF (N)  136,136,102
102	WRITE (III,154)
	WRITE (III,152)
	DO 104 I=1,N
104	READ (NBLANK)ATOM(I),ATOMC,X1(I),Y1(I),Z1(I),XX,YY,ZZ,D(I),DS12U2(
	1I),DS12V2(I),DS12W2(I),DS12U1(I),DS12V1(I),DS12W1(I),DS12DA(I),DS1
	12DB(I),DS12DC(I),DS12AL(I),DS12BE(I),DS12GA(I),SD,ITBX,ITBY,MJ(I),
	1ML(I),MI(I)
	DO 135 J=1,N
	IF (ANGMAX-D(J))  135,106,106
106	M=J+1
	IF (M-N)  107,107,135
107	DO 134 K=M,N
	IF (ANGMAX-D(K))  134,108,108
108	DELX=(X1(K)-X1(J))
	DELY=(Y1(K)-Y1(J))
	DELZ=(Z1(K)-Z1(J))
	DX=DELX*A
	DY=DELY*B
	DZ=DELZ*C
	DISTSQ=DX**2+DY**2+DZ**2+2.D0*DY*DZ*COSA+2.D0*DX*DZ*COSB+2.D0*DX*D
	1Y*COSC
	COSPHI=((D(K))**2+(D(J))**2-DISTSQ)/(2.D0*(D(K))*(D(J)))
	IF (COSPHI+1.D0)  109,110,110
109	COSPHI=1.D0
110	SINPHI=DSQRT(1.0D0-COSPHI**2)
	IF (COSPHI)  112,111,112
111	PHI=90.0D0
	GO TO 114
112	PHI=(DATAN(SINPHI/COSPHI))*RAD
	IF (PHI)  113,113,114
113	PHI=180.D0+PHI
114	DIST=DSQRT(DISTSQ)
	X1D=X1(J)-1.0D0
	Y1D=Y1(J)-1.0D0
	Z1D=Z1(J)-1.0D0
	X2D=XX-1.0D0
	Y2D=YY-1.0D0
	Z2D=ZZ-1.0D0
	X3D=X1(K)-1.0D0
	Y3D=Y1(K)-1.0D0
	Z3D=Z1(K)-1.0D0
	IF (NSDANG)  115,133,115
115	CALL DERPAR
	CALL CONANG(D(J),D(K),DIST,COSPHI,SINPHI,C1,C2,C3,C4)
	DPHIC(1)=DPHI(C1,C2,C3,C4,DS12DA(J),DS12DA(K),DLDA)
	DPHIC(2)=DPHI(C1,C2,C3,C4,DS12DB(J),DS12DB(K),DLDB)
	DPHIC(3)=DPHI(C1,C2,C3,C4,DS12DC(J),DS12DC(K),DLDC)
	DPHIC(4)=DPHI(C1,C2,C3,C4,DS12AL(J),DS12AL(K),DLDAL)
	DPHIC(5)=DPHI(C1,C2,C3,C4,DS12BE(J),DS12BE(K),DLDBE)
	DPHIC(6)=DPHI(C1,C2,C3,C4,DS12GA(J),DS12GA(K),DLDGA)
	GO TO (119,119,119,118,116,118,117),NSYM
116	DPHIC(4)=DPHIC(4)+DPHIC(5)+DPHIC(6)
	DPHIC(5)=0.0D0
	DPHIC(6)=0.0D0
117	DPHIC(1)=DPHIC(1)+DPHIC(3)
	DPHIC(3)=0.0D0
118	DPHIC(1)=DPHIC(1)+DPHIC(2)
	DPHIC(2)=0.0D0
119	SIGSQ=0.0D0
	DO 120 I=1,6
120	SIGSQ=SIGSQ+DPHIC(I)*DPHIC(I)
	CALL DERDIS(MJ(K),MJ(J),MI(K),MI(J),X1(K),Y1(K),Z1(K),X1(J),Y1(J),
	1Z1(J))
C     DPHI/DATOM2
	DPHIC(1)=DPHI(C1,C2,C3,C4,DS12U2(J),DS12U2(K),0.0D0)
	DPHIC(2)=DPHI(C1,C2,C3,C4,DS12V2(J),DS12V2(K),0.0D0)
	DPHIC(3)=DPHI(C1,C2,C3,C4,DS12W2(J),DS12W2(K),0.0D0)
C     DPHI/DATOM1
	DPHIC(4)=DPHI(C1,C2,C3,C4,DS12U1(J),0.0D0,-DLDX1)
	DPHIC(5)=DPHI(C1,C2,C3,C4,DS12V1(J),0.0D0,-DLDY1)
	DPHIC(6)=DPHI(C1,C2,C3,C4,DS12W1(J),0.0D0,-DLDZ1)
C     DPHI/DATOM3
	DPHIC(7)=DPHI(C1,C2,C3,C4,0.0D0,DS12U1(K),-DLDX2)
	DPHIC(8)=DPHI(C1,C2,C3,C4,0.0D0,DS12V1(K),-DLDY2)
	DPHIC(9)=DPHI(C1,C2,C3,C4,0.0D0,DS12W1(K),-DLDZ2)
	IF (ML(J)-MI(J))  124,123,124
123	DPHIC(1)=DPHIC(1)+DPHIC(4)
	DPHIC(2)=DPHIC(2)+DPHIC(5)
	DPHIC(3)=DPHIC(3)+DPHIC(6)
	DPHIC(4)=0.0D0
	DPHIC(5)=0.0D0
	DPHIC(6)=0.0D0
124	IF (ML(K)-MI(K))  126,125,126
125	DPHIC(1)=DPHIC(1)+DPHIC(7)
	DPHIC(2)=DPHIC(2)+DPHIC(8)
	DPHIC(3)=DPHIC(3)+DPHIC(9)
	GO TO 128
126	IF (MI(J)-MI(K))  129,127,129
127	DPHIC(4)=DPHIC(4)+DPHIC(7)
	DPHIC(5)=DPHIC(5)+DPHIC(8)
	DPHIC(6)=DPHIC(6)+DPHIC(9)
128	DPHIC(7)=0.0D0
	DPHIC(8)=0.0D0
	DPHIC(9)=0.0D0
129	DO 130 I=1,3
	DO 130 L=I,3
130	SIGSQ=SIGSQ+DPHIC(I)*DPHIC(L)*Q(I,L)
	DO 131 I=4,6
	IR=I-3
	DO 131 L=I,6
	LR=L-3
131	SIGSQ=SIGSQ+DPHIC(I)*DPHIC(L)*Q(IR,LR)
	DO 132 I=7,9
	IR=I-6
	DO 132 L=I,9
	LR=L-6
132	SIGSQ=SIGSQ+DPHIC(I)*DPHIC(L)*Q(IR,LR)
	SIGMA=DSQRT(SIGSQ)
	SDANG=SIGMA*RAD
133	WRITE (III,157) ATOM(J),ATOMC,ATOM(K),PHI,SDANG,D(J),D(K),DIST,X1D
	1,Y1D,Z1D,X2D,Y2D,Z2D,X3D,Y3D,Z3D
134	CONTINUE
135	CONTINUE
136	CONTINUE
137	REWIND NBLANK
	WRITE (III,141) TITLE
	WRITE (III,149) A,SIGA,B,SIGB,C,SIGC,ALPHA,SIGALF,BETA,SIGBET,GAMM
	1A,SIGGAM,COSA,COSB,COSC,SINA,SINB,SINC,V
399	CALL DISLIS
	READ (II,167) NEWDAT
	IF (NEWDAT.NE.0) GO TO 168
139	STOP
141	FORMAT (1HP,72A1)
143	FORMAT (10H NEQUIV = I3,/10H NATOM  = I3/10H DMAX   = F10.5/
	19H DXMAX = F6.2/9H DYMAX = F6.2/9H DZMAX = F6.2)
144	FORMAT (15F3.0)
145	FORMAT (///32H1LIST OF ATOMIC INPUT POSITIONS.//
	134H             X        Y        Z       //)
146	FORMAT (A6,12X,5F9.6,I2)
147	FORMAT (6F9.6)
148	FORMAT (6F10.5)
149	FORMAT (5H0A = F8.4,8H + OR - F6.4/5H B = F8.4,8H + OR - F6.4/
	15H C = F8.4,8H + OR - F6.4/9H ALPHA = F8.3,8H + OR - F6.4/
	19H BETA  = F8.3,8H + OR - F6.4/9H GAMMA = F8.3,8H + OR - F6.4/
	113H COS ALPHA = F8.5/13H COS BETA  = F8.5/13H COS GAMMA = F8.5/
	113H SIN ALPHA = F8.5/13H SIN BETA  = F8.5/13H SIN GAMMA = F8.5/
     15H V = F12.6/)
150	FORMAT (1H A6,2XA6,3F8.4,2X3F8.4,5XF10.4,F7.4,3F10.4)
151	FORMAT ('0ATOM1 TO ATOM2     X,Y,Z OF ATOM1            X,Y,Z OF',
	1' ATOM2            DISTANCE  S.D.    2 ON 1     1 ON 2   INDEP.'
	1//)
152	FORMAT (1H0)
153	FORMAT (3F10.8)
154	FORMAT ('0ATOM1 ATOM2 ATOM3   ANGLE    SD        DIST12  DIST23',
	1'  DIST13           XYZ OF ATOM1       XYZ OF ATOM2       XYZ ',
	1'OF ATOM3   ')
155	FORMAT (1H1)
156	FORMAT (54X10H**********/54X10H* ANGLES */54X10H**********/1H0)
157	FORMAT (1X3A6,F8.2,F6.2,5X3F8.3,8X2(3F6.3,1H ),3F6.3)
158	FORMAT (37X,13H*************/37X13H* DISTANCES */37X,
	113H*************/1H0)
159	FORMAT (6H0A* = F10.8/6H B* = F10.8/6H C* = F10.8/10H ALPHA* = F8.
	13/10H BETA*  = F8.3/10H GAMMA* = F8.3/14H COS ALPHA* = F8.5/
	114H COS BETA*  = F8.5/14H COS GAMMA* = F8.5/14H SIN ALPHA* = F8.5/
	114H SIN BETA*  = F8.5/14H SIN GAMMA* = F8.5///)
160	FORMAT (50H1THE HEADINGS 2 ON 1 MEANS ATOM2 RIDES ON ATOM1.  /
	154H0INDEP. MEANS INDEPENDENT MOTION OF ATOM1 AND ATOM2.   ////)
161	FORMAT (29H THE TEMPERATURE FACTOR OF   A6,
	1' ARE NOT POSITIVE-DEFINITE. ')
162	FORMAT (' THE AVERAGE ROOT MEAN SQUARE DISPLACEMENT (UBAR) OF AT',
	1'OM 'A6,4H IS F8.4,12H ANGSTROMS. ///)
163	FORMAT (72A1)
164	FORMAT (1H 72A1)
166	FORMAT (1X,A6,3F10.4,F6.2)
167	FORMAT (I1)
	END

	SUBROUTINE DISLIS
	IMPLICIT REAL*8 (A-H,O-Z)
	REAL*8 NAMEXX,NAMX,AOO,OBO,OOC
	COMMON/CELLS/A,B,C,COSA,COSB,COSC,SINA,SINB,SINC,ASTAR,BSTAR,CSTAR
	1,COSAST,COSBST,COSCST,SINAST,SINBST,SINCST,NSYM
	COMMON/LISDIS/ATOM,D,R,X,Y,Z,U,V,W,P,NBLANK,III,NDIST,NATOM,IDRILL
	1,ITRANS,NEQUIV
	COMMON/IDX/ BTOM(100)
C     DIMENSION ATOM(100),D(50),SSDD(50),NDIST(100),X(50),Y(50),Z(50)
C     DIMENSION U(100,48),V(100,48),W(100,48)
	DIMENSION ATOM(40),D(50),SSDD(50),NDIST(40),X(50),Y(50),Z(50)
	DIMENSION U(40,192),V(40,192),W(40,192)
	DIMENSION P(3,3),R(3,3)
	EQUIVALENCE (ATOMI,IATOMI),(ATOMJ,IATOMJ)
	DATA NAMEXX/8H        /
	DATA AOO/8H 1 0 0  /,OBO/8H 0 1 0  /,OOC/8H 0 0 1  /
	CONV=180.0/3.1415626
C
C     CALCULATE TRANSFORMATION MATRIX FOR ORTHOGONAL COORDINATES
C
	WRITE (III,501)  ((R(I,J),J=1,3),I=1,3)
501	FORMAT('0R MATRIX 501'/1X,3E15.6/1X,3E15.6/1X,3E15.6)
	IF (IDRILL) 399,399,301
301	IF (ITRANS) 302,302,305
302	IF (NSYM-2) 303,304,303
303	ITRANS=3
	GO TO 305
304	ITRANS=2
305	DO 306 I=1,3
	DO 306 J=1,3
306	R(I,J)=0.0
	GO TO (307,308,309),ITRANS
307	R(3,1)=A
	R(3,2)=B*COSC
	R(3,3)=C*COSB
	R(1,2)=B*SINC
	R(1,3)=(-C)*SINB*COSAST
	R(2,3)=C*SINB*SINAST
	NAMX=AOO
	GO TO 310
308	R(2,1)=A*SINC*SINBST
	R(3,1)=A*COSC
	R(3,2)=B
	R(3,3)=C*COSA
	R(1,1)=(-A)*SINC*COSBST
	R(1,3)=C*SINA
	NAMX=OBO
	GO TO 310
309	R(1,1)=A*SINB
	R(1,2)=(-B)*SINA*COSCST
	R(2,2)=B*SINA*SINCST
	R(3,1)=A*COSB
	R(3,2)=B*COSA
	R(3,3)=C
	NAMX=OOC
	III=6
310	WRITE (III,311) NAMX
311	FORMAT ('1COORDINATES OF ATOMS IN ORTHOGONAL PROJECTION ALONG ',A6
	1/'0',1X)
	IC=1
	JC=0
	KC=0
	WRITE (III,502)  ((R(I,J),J=1,3),I=1,3)
502	FORMAT('0R MATRIX 502'/1X,3E15.6/1X,3E15.6/1X,3E15.6)
	DO 3120 I=1,7
	XX=IC*R(1,1)+JC*R(1,2)+KC*R(1,3)
	YY=IC*R(2,1)+JC*R(2,2)+KC*R(2,3)
	ZZ=IC*R(3,1)+JC*R(3,2)+KC*R(3,3)
	WRITE (III,3100) IC,JC,KC,XX,YY,ZZ
3100	FORMAT ('0    THE COORDINATES OF THE POINT X,Y,Z = ',I1,',',I1,','
	1,I1,' IN ORTHOGONAL SPACE ARE ',3F7.3)
	IC=1-IC
	IF (IC-0) 3121,3118,3120
3118	JC=1-JC
	IF (JC-0) 3121,3119,3120
3119	KC=1-KC
3120	CONTINUE
3121	WRITE (III,3110)
3110	FORMAT ('0 ATOM',15X,'FRACTIONAL COORDINATES',16X,'CRYSTAL SPACE C
	1OORDINATES',14X,'PROJECTION SPACE COORDINATES')
	DO 316 I=1,NATOM
	WRITE (III,312) BTOM(I)
C     WRITE (III,312) I
312	FORMAT ('0 ',A6,3(14X,'X',9X,'Y',9X,'Z',3X)/'0')
C 312 FORMAT ('0 ',I6,3(14X,'X',9X,'Y',9X,'Z',3X)/'0')
	DO 315 J=1,NEQUIV
	IF (U(I,J)-100.0D0) 313,315,315
313	XX=U(I,J)*A
	YY=V(I,J)*B
	ZZ=W(I,J)*C
	XXX=R(1,1)*U(I,J)+R(1,2)*V(I,J)+R(1,3)*W(I,J)
	YYY=R(2,1)*U(I,J)+R(2,2)*V(I,J)+R(2,3)*W(I,J)
	ZZZ=R(3,1)*U(I,J)+R(3,2)*V(I,J)+R(3,3)*W(I,J)
	WRITE (III,314) U(I,J),V(I,J),W(I,J),XX,YY,ZZ,XXX,YYY,ZZZ
314	FORMAT (7X,3(8X,3F10.4))
315	CONTINUE
316	CONTINUE
399	CONTINUE
	DO 28 L=1,NATOM
	NT=NDIST(L)
	IF (NT)  29,29,2
2	KT=NT
	IF (NT-50)  5,5,3
3	NT=50
	WRITE (III,4) KT,NT
4	FORMAT (4H NT=I4,18H HAS BEEN RESET TOI4)
5	DO 6 I=1,NT
6	READ (NBLANK)ATOM(I),ATOMX,X(I),Y(I),Z(I),XX,YY,ZZ,D(I),Q7,Q8,Q9,Q
	110,Q11,Q12,Q13,Q14,Q15,Q16,Q17,Q18,SSDD(I),ITBL,ITBX
	IF (KT-NT)  9,9,7
7	DO 8 I=51,KT
8	READ (NBLANK)SKIP
9	CONTINUE
	DO 13 I=1,NT
	DO 12 J=I,NT
10	IF (D(I)-D(J))  12,12,11
11	DSAVE=D(I)
	ASAVE=ATOM(I)
	SSAVE=SSDD(I)
	XSAVE=X(I)
	YSAVE=Y(I)
	ZSAVE=Z(I)
	D(I)=D(J)
	ATOM(I)=ATOM(J)
	SSDD(I)=SSDD(J)
	X(I)=X(J)
	Y(I)=Y(J)
	Z(I)=Z(J)
	D(J)=DSAVE
	ATOM(J)=ASAVE
	SSDD(J)=SSAVE
	X(J)=XSAVE
	Y(J)=YSAVE
	Z(J)=ZSAVE
	GO TO 10
12	CONTINUE
13	CONTINUE
	WRITE (III,98)
98	FORMAT ('1',44X,'TABLE OF DRILLING COORDINATES')
	IF (IDRILL) 100,30,100
C
C     OUTPUT LIST OF COORDINATES
C
100	XXX=R(1,1)*XX+R(1,2)*YY+R(1,3)*ZZ
	YYY=R(2,1)*XX+R(2,2)*YY+R(2,3)*ZZ
	ZZZ=R(3,1)*XX+R(3,2)*YY+R(3,3)*ZZ
	WRITE (III,101) ATOMX,XX,YY,ZZ
101	FORMAT ('0DRILLING COORDINATES ABOUT  ',A6,' (',F8.4,',',F8.4,',',
	1F8.4/'0ATOM(2)    DISTANCE    S.D.',10X,'RHO     PHI(LH)   PHI(RH)
	2',10X,'X',9X,'Y',9X,'Z',11X,'XO',6X,'YO',6X,'ZO'/'0')
	DO 115 I=1,NT
	XX=R(1,1)*X(I)+R(1,2)*Y(I)+R(1,3)*Z(I)-XXX
	YY=R(2,1)*X(I)+R(2,2)*Y(I)+R(2,3)*Z(I)-YYY
	ZZ=R(3,1)*X(I)+R(3,2)*Y(I)+R(3,3)*Z(I)-ZZZ
	IF (I-2) 102,103,103
102	IF (XX.EQ.0.0.AND.YY.EQ.0.0) GO TO 530
	ROOT=DSQRT(XX*XX+YY*YY)
	P(1,1)=(XX*ZZ)/(ROOT*D(I))
	P(1,2)=(YY*ZZ)/(ROOT*D(I))
	P(1,3)=(-ROOT)/D(I)
	P(2,1)=(-YY)/ROOT
	P(2,2)=XX/ROOT
	P(2,3)=0.0
	P(3,1)=XX/D(I)
	P(3,2)=YY/D(I)
	P(3,3)=ZZ/D(I)
510	I180=1
1020	RHO=0.0
	XXF=0.0
	ZZF=D(I)
	GO TO 1085
530	P(1,1)=1.0
	P(1,2)=0.0
	P(1,3)=0.0
	P(2,1)=0.0
	P(2,2)=1.0
	P(2,3)=0.0
	P(3,1)=0.0
	P(3,2)=0.0
	P(3,3)=1.0
	GO TO 510
103	XXN=P(1,1)*XX+P(1,2)*YY+P(1,3)*ZZ
	YYN=P(2,1)*XX+P(2,2)*YY+P(2,3)*ZZ
	ZZF=P(3,1)*XX+P(3,2)*YY+P(3,3)*ZZ
108	IF (DABS(XXN)-0.0001) 104,104,107
104	IF (DABS(YYN)-0.0001) 105,105,107
105	IF (ZZF) 106,1110,1020
106	RHO=180.0
	XXF=0.0
	GO TO 1085
107	RHOS=ZZF/D(I)
	IF (DABS(RHOS)-1.0) 1070,1070,1110
1070	RHO=DACOS(RHOS)*CONV
	IF (I180) 1080,109,1080
1080	XXF=DSQRT(XXN*XXN+YYN*YYN)
	COSB=XXN/XXF
	SINB=YYN/XXF
	I180=0
1085	PHIR=0.0
	PHIL=0.0
	YYF=0.0
	GO TO 113
1110	WRITE (III,1111) ATOM(I),D(I),X(I),Y(I),Z(I),ZZF,RHOS
1111	FORMAT(1X,A6,2X,F10.4,61X,3F10.4/' ZZF=',F10.4,'ZZF/D(I) =',F10.4)
	GO TO 115
109	XXF=XXN*COSB+YYN*SINB
	YYF=YYN*COSB-XXN*SINB
	PHIR=DACOS(XXF/DSQRT(XXF*XXF+YYF*YYF))*CONV
	PHIL=360.0-PHIR
	IF (YYF) 116,113,113
116	PHI=PHIR
	PHIR=PHIL
	PHIL=PHI
113	WRITE (III,114) ATOM(I),D(I),SSDD(I),RHO,PHIR,PHIL,X(I),Y(I),Z(I),
	1XXF,YYF,ZZF
114	FORMAT (1X,A6,2X,2F10.4,4X,3F10.2,4X,3F10.4,4X,3F8.3)
115	CONTINUE
	GO TO 28
30	WRITE (III,1)
1	FORMAT ('1TABLE OF DISTANCES')
	NIJ=1
	DO 26 I=1,NT
	IF (NIJ-1)  14,15,14
14	NIJ=NIJ-1
	GO TO 26
15	IJ=I+1
	DO 18 J=IJ,NT
	IF (0.00001D0-DABS(D(I)-D(J)))  19,16,16
16	ATOMI=ATOM(I)
	ATOMJ=ATOM(J)
	IF (IATOMI-IATOMJ)  19,17,19
17	NIJ=NIJ+1
18	CONTINUE
19	IF (I-1)  21,21,20
20	ATOMX=NAMEXX
21	IF (NIJ-1)  22,22,24
22	WRITE (III,23) ATOMX,ATOM(I),D(I),SSDD(I)
23	FORMAT (1H A6,5H -   A6,1H F6.3,3H   F4.3,2H A)
	GO TO 26
24	WRITE (III,25) ATOMX,NIJ,ATOM(I),D(I),SSDD(I)
25	FORMAT (1H A6,2H -I3,A6,1H F6.3,3H   F4.3,2H A)
26	CONTINUE
	WRITE (III,27)
27	FORMAT (1H0)
28	CONTINUE
29	CONTINUE
	REWIND NBLANK
	RETURN
	END

	SUBROUTINE NEISR(I,RN,S1,S2,S3,NEQUIV,NCENT,NEI)
	 IMPLICIT REAL*8 (A-H,O-Z)
C     DIMENSION RN(48,3),S1(48,3),S2(48,3),S3(48,3),KJ(2)
	DIMENSION RN(192,3),S1(192,3),S2(192,3),S3(192,3),KJ(2)
	NTOUT=6
	CP33=1.D0/3.D0
	CP67=2.D0/3.D0
	J=I+NEQUIV
	K=I+NEQUIV
	IF (NCENT)  1,2,1
1	K=K+NEQUIV
2	N=NEI+1
	K1=K
	KJ(1)=K
	KJ(2)=I
	GO TO (3,4,5,6,7,8,9,10,11,13),N
3	RETURN
C
C A-CENTERED
4	CALL ADDEP(KJ,RN,0.D0,.5D0,.5D0)
	GO TO 14
C
C B-CENTERED
5	CALL ADDEP(KJ,RN,.5D0,0.D0,.5D0)
	GO TO 14
C
C C-CENTERED
6	CALL ADDEP(KJ,RN,.5D0,.5D0,0.D0)
	GO TO 14
C
C F-CENTERED
7	CALL ADDEP(KJ,RN,.5D0,.5D0,0.D0)
	K=K+NEQUIV
	KJ(1)=K
	CALL ADDEP(KJ,RN,.5D0,0.D0,.5D0)
	K=K+NEQUIV
	KJ(1)=K
	CALL ADDEP(KJ,RN,0.D0,.5D0,.5D0)
	GO TO 14
C
C I-CENTERED
8	CALL ADDEP(KJ,RN,.5D0,.5D0,.5D0)
	GO TO 14
C
C R-CENTERED(OBVERSE)
9	CALL ADDEP(KJ,RN,CP33,CP67,CP67)
	K=K+NEQUIV
	KJ(1)=K
	CALL ADDEP(KJ,RN,CP67,CP33,CP33)
	GO TO 14
C
C R-CENTERED(REVERSE)
10	CALL ADDEP(KJ,RN,CP33,CP67,CP33)
	K=K+NEQUIV
	KJ(1)=K
	CALL ADDEP(KJ,RN,CP67,CP33,CP67)
	GO TO 14
C
C ERROR MESSAGE
11	WRITE (NTOUT,12)
12	FORMAT (51HN=8 UNDEFINED FOR EQUIVALENT POSITION SET EXPANSION)
	GO TO 3
C
C PRIMITIVE
13	GO TO 3
C
C
14	L=I
	KK=K
	DO 16 K=K1,KK,NEQUIV
	DO 15 J=1,3
	S1(K,J)=S1(L,J)
	S2(K,J)=S2(L,J)
15	S3(K,J)=S3(L,J)
16	WRITE (NTOUT,20) (RN(K,J),S1(K,J),S2(K,J),S3(K,J),J=1,3)
	IF (NCENT.GT.0) GO TO 17
	IF (I.LT.NEQUIV) GO TO 3
	NEQUIV=KK
	GO TO 3
17	L=KK
	DO 19 K=K1,KK,NEQUIV
	L=L+NEQUIV
	DO 18 J=1,3
	RN(L,J)=RN(K,J)
	S1(L,J)=-S1(K,J)
	S2(L,J)=-S2(K,J)
18	S3(L,J)=-S3(K,J)
	WRITE (NTOUT,20) (RN(L,J),S1(L,J),S2(L,J),S3(L,J),J=1,3)
19	CONTINUE
20	FORMAT (3(F6.3,3F3.0))
	IF (I.LT.NEQUIV) GO TO 3
	NEQUIV=L/2
	GO TO 3
	END

	SUBROUTINE ADDEP(KJ,RN,DX,DY,DZ)
	 IMPLICIT REAL*8 (A-H,O-Z)
C     DIMENSION RN(48,3),KJ(2)
	DIMENSION RN(192,3),KJ(2)
	DIMENSION DEL(3)
	K=KJ(1)
	J=KJ(2)
	DEL(1)=DX
	DEL(2)=DY
	DEL(3)=DZ
	DO 3 I=1,3
	DEL(I)=DEL(I)+RN(J,I)
	DEL(I)=DMOD(DEL(I),1.0D0)
	IF (DABS(DEL(I)-.00001D0))  1,1,2
1	DEL(I)=0.D0
	GO TO 3
2	IF (DABS(DABS(DEL(I)-1.D0)))  1,1,3
3	RN(K,I)=DEL(I)
	RETURN
	END

	SUBROUTINE CONANG(S12,S23,S13,COSPHI,SINPHI,C1,C2,C3,C4)
	 IMPLICIT REAL*8 (A-H,O-Z)
	IF (SINPHI-.00001D0)  2,2,1
1	C1=(1.0D0/S23-COSPHI/S12)
	C2=(1.0D0/S12-COSPHI/S23)
	C3=-(S13/(S12*S23))
	C4=-1.0D0/SINPHI
	GO TO 3
2	C4=0.0D0
3	RETURN
	END

	SUBROUTINE DERDIS(K,J,L,I,XXXX,YYYY,ZZZZ,XPX,YPY,ZPZ)
	 IMPLICIT REAL*8 (A-H,O-Z)
	COMMON/CELLS/A,B,C,COSA,COSB,COSC,SINA,SINB,SINC,ASTAR,BSTAR,CSTAR
	1,COSAST,COSBST,COSCST,SINAST,SINBST,SINCST,NSYM
	COMMON/DISDER/S1,S2,S3,SIGX,SIGY,SIGZ,DLDX1,DLDX2,DLDY1,DLDY2,DLDZ
	11,DLDZ2
C     DIMENSION S1(48,3),S2(48,3),S3(48,3),SIGX(100),SIGY(100),SIGZ(100)
	DIMENSION S1(192,3),S2(192,3),S3(192,3),SIGX(40),SIGY(40),SIGZ(40)
	DLDX2=DLDV(S1(K,1),S1(K,2),S1(K,3))*SIGX(L)
	DLDX1=-DLDV(S1(J,1),S1(J,2),S1(J,3))*SIGX(I)
	DLDY2=DLDV(S2(K,1),S2(K,2),S2(K,3))*SIGY(L)
	DLDY1=-DLDV(S2(J,1),S2(J,2),S2(J,3))*SIGY(I)
	DLDZ2=DLDV(S3(K,1),S3(K,2),S3(K,3))*SIGZ(L)
	DLDZ1=-DLDV(S3(J,1),S3(J,2),S3(J,3))*SIGZ(I)
	IF (I-L)  2,1,2
1	DLDX2=DLDX2+DLDX1
	DLDY2=DLDY2+DLDY1
	DLDZ2=DLDZ2+DLDZ1
	DLDX1=0.D0
	DLDY1=0.D0
	DLDZ1=0.D0
2	GO TO (6,6,6,3,3,3,3),NSYM
3	CALL X2XXX(XXXX,YYYY,DLDX2,DLDY2,SIGX(L),S2(K,1),S2(K,2),S2(K,3))
	CALL X2XXX(XPX,YPY,DLDX1,DLDY1,-SIGX(I),S2(J,1),S2(J,2),S2(J,3))
	GO TO (6,6,6,6,5,6,5),NSYM
5	CALL X2XXX(XXXX,ZZZZ,DLDX2,DLDZ2,SIGX(L),S3(K,1),S3(K,2),S3(K,3))
	CALL X2XXX(XPX,ZPZ,DLDX1,DLDZ1,-SIGX(I),S3(J,1),S3(J,2),S3(J,3))
6	RETURN
	END

	SUBROUTINE DERPAR
	 IMPLICIT REAL*8 (A-H,O-Z)
	COMMON/CELLS/A,B,C,COSA,COSB,COSC,SINA,SINB,SINC,ASTAR,BSTAR,CSTAR
	1,COSAST,COSBST,COSCST,SINAST,SINBST,SINCST,NSYM
	COMMON/PARDER/SIGA,SIGB,SIGC,SIGALF,SIGBET,SIGGAM,DLDA,DLDB,DLDC,D
	1LDAL,DLDBE,DLDGA,DX,DY,DZ
	COMMON/DLDVV/ASQARE,BSQARE,CSQARE,ABCOSC,ACCOSB,BCCOSA,DELX,DELY,D
	1ELZ,DIST
	DLDAL=0.0D0
	DLDBE=0.0D0
	DLDGA=0.0D0
	DLDA=(DELX*(DX+DZ*COSB+DY*COSC))*(SIGA/DIST)
	DLDB=(DELY*(DY+DZ*COSA+DX*COSC))*(SIGB/DIST)
	DLDC=(DELZ*(DZ+DY*COSA+DX*COSB))*(SIGC/DIST)
	GO TO (2,3,4,4,2,4,4),NSYM
2	DLDAL=(-DY*DZ*SINA)*(SIGALF/DIST)
	DLDGA=(-DX*DY*SINC)*(SIGGAM/DIST)
3	DLDBE=(-DX*DZ*SINB)*(SIGBET/DIST)
4	GO TO (8,8,8,7,5,7,6),NSYM
5	DLDAL=DLDAL+DLDBE+DLDGA
	DLDBE=0.0D0
	DLDGA=0.0D0
6	DLDA=DLDA+DLDC
	DLDC=0.0D0
7	DLDA=DLDA+DLDB
	DLDB=0.0D0
8	RETURN
	END

	FUNCTION DET3X3(A)
C
CDET3X3
C     SOLVES 3X3 DETERMINANTS.
C
	 IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION A(3,3)
	DET3X3=A(1,1)*(A(2,2)*A(3,3)-A(3,2)*A(2,3))-A(1,2)*(A(2,1)*A(3,3)-
	1A(3,1)*A(2,3))+A(1,3)*(A(2,1)*A(3,2)-A(3,1)*A(2,2))
	RETURN
	END

	FUNCTION DLDV(DV1,DV2,DV3)
CDLDV
	 IMPLICIT REAL*8 (A-H,O-Z)
	COMMON/DLDVV/ASQARE,BSQARE,CSQARE,ABCOSC,ACCOSB,BCCOSA,DELX,DELY,D
	1ELZ,DIST
	DLDV=(ASQARE*DELX*DV1+BSQARE*DELY*DV2+CSQARE*DELZ*DV3+ABCOSC*(DELX
	1*DV2+DELY*DV1)+ACCOSB*(DELX*DV3+DELZ*DV1)+BCCOSA*(DELY*DV3+DELZ*DV
	12))/DIST
	RETURN
	END

	FUNCTION DPHI(C1,C2,C3,C4,DS12DV,DS23DV,DS13DV)
CDPHI
	 IMPLICIT REAL*8 (A-H,O-Z)
	DPHI=(C1*DS12DV+C2*DS23DV+C3*DS13DV)*C4
	RETURN
	END

	SUBROUTINE MATMUL(A,B,C)
CMATMUL
C     MULTIPLIES 3X3 MATRICES SUCH THAT C = A X B.
C
	 IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION A(3,3),B(3,3),C(3,3)
	DO 1 I=1,3
	DO 1 J=1,3
1	C(I,J)=0.0D0
	DO 2 I=1,3
	DO 2 J=1,3
	DO 2 K=1,3
2	C(I,J)=C(I,J)+A(I,K)*B(K,J)
	RETURN
	END

	SUBROUTINE MATRAN(A,B)
CMATRAN
C     TRANSPOSE 3X3 MATRIX SUCH THAT  B= TRANSPOSE OF A.
C
	 IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION A(3,3),B(3,3)
	DO 1 I=1,3
	DO 1 J=1,3
1	B(J,I)=A(I,J)
	RETURN
	END

	FUNCTION MATTST(B)
CMATTST
	 IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION B(3,3)
	IF (B(1,1))  8,1,1
1	IF (B(2,2))  8,2,2
2	IF (B(3,3))  8,3,3
3	IF (B(1,1)*B(2,2)-B(1,2)*B(2,1))  8,4,4
4	IF (B(1,1)*B(3,3)-B(1,3)*B(3,1))  8,5,5
5	IF (B(2,2)*B(3,3)-B(2,3)*B(3,2))  8,6,6
6	IF (DET3X3(B))  8,7,7
C     MATRIX IS POSITIVE-DEFINITE
7	MATTST=1
	GO TO 9
C     MATRIX IS NOT POSITIVE-DEFINITE
8	MATTST=-1
9	RETURN
	END

	SUBROUTINE X2XXX(XX,YY,DLDX2,DLDY2,SIGX,S2J1,S2J2,S2J3)
CX2XX
	 IMPLICIT REAL*8 (A-H,O-Z)
	XXTEMP=XX+1.0D0
	YYTEMP=YY+1.0D0
1	IF (XXTEMP-1.0D0)  3,3,2
2	XXTEMP=XXTEMP-1.0D0
	GO TO 1
3	IF (YYTEMP-1.0D0)  5,5,4
4	YYTEMP=YYTEMP-1.0D0
	GO TO 3
C     X2 = Y2
5	IF (DABS(XXTEMP-YYTEMP)-.00001D0)  15,15,6
C     X2 = -Y2
6	IF (DABS(1.0D0-XXTEMP+YYTEMP)-.00001D0)  15,15,7
C     2X2 = Y2
7	TWOX2=2.0D0*XXTEMP
	IF (TWOX2-1.0D0)  9,9,8
8	TWOX2=TWOX2-1.0D0
9	IF (DABS(TWOX2-YYTEMP)-.00001D0)  15,15,10
C     2X2 = - Y2
10	IF (DABS(1.0D0-TWOX2+YYTEMP)-.00001D0)  15,15,11
C     2Y2 = X2
11	TWOY2=2.0D0*YYTEMP
	IF (TWOY2-1.0D0)  13,13,12
12	TWOY2=TWOY2-1.0D0
13	IF (DABS(TWOY2-XXTEMP)-.00001D0)  15,15,14
C     2Y2 = -X2
14	IF (DABS(1.0D0-TWOY2+XXTEMP)-.00001D0)  15,15,16
15	XULT=YYTEMP/XXTEMP
	DLDX2=DLDX2+DLDV(S2J1,S2J2,S2J3)*SIGX*XULT
	DLDY2=0.0D0
16	RETURN
	END

	SUBROUTINE TRANSL(LCHAR,RNUM,RDEN,RCX,RCY,RCZ)
	IMPLICIT REAL*8 (A-H,O-Z)
	LOGICAL*1 LALPHA,LCHAR,LCH,LALPOS,LALNEG,LALFAX,LALFAY,LALFAZ,
	1LALSP,LALSLH,LALCOM
	DIMENSION LALPHA(9),LCHAR(72),RNUM(3),RDEN(3),RCX(3),RCY(3),RCZ(3)
	DATA LALPHA/1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/,LALPOS/1H+/,
	1LALNEG/1H-/,LALCOM/1H,/,LALFAX/1HX/,LALFAY/1HY/,LALFAZ/1HZ/,
	2LALSP/1H /,LALSLH/1H//
C
C     TRANSLATE X,Y,Z FORMAT TO INTERNAL FORMAT
C
C     BEGIN LOOP THRU ITH COORDINATE
C
	NJ=1
	DO 265 I=1,3
C     INITIALIZE LALS VARIABLES
	RNUM(I)=0.0
	RDEN(I)=0.0
	RCX(I)=0.0
	RCY(I)=0.0
	RCZ(I)=0.0
	XN=1.0
C
C     BEGIN LOOP BETWEEN COMMAS ON INPUT CARD
C
	DO 245 J=NJ,72
	LCH=LCHAR(J)
C
C     CHECK FOR NUMBER
C
	DO 2 K=1,9
	IF (LCH.NE.LALPHA(K)) GO TO 2
C     CHECK FOR NONZERO NUMERATOR
	IF (RNUM(I).NE.0.0) GO TO 155
C
145	XNUM=K
	XN=XNUM*XN
	GO TO 245
C     CHECK FOR NONZERO DENOMINATOR
155	IF (RDEN(I).NE.0.0)GO TO 145
	RDEN(I)=K
	GO TO 235
2	CONTINUE
C
C     CHECK FOR X,Y, OR Z AND SET JC*(I) TO VALUE OF NN IF FOUND
C
	IF (LCH.NE.LALFAX) GO TO 185
	RCX(I)=XN
	GO TO 235
185	IF (LCH.NE.LALFAY) GO TO 195
	RCY(I)=XN
	GO TO 235
195	IF (LCH.NE.LALFAZ) GO TO 205
	RCZ(I)=XN
	GO TO 235
C     PLUS(+) - IGNORE
205	IF (LCH.EQ.LALPOS) GO TO 245
C     COMMA (,) - END OF LOOP THRU ITH COORDINATE
	IF (LCH.EQ.LALCOM) GO TO 255
C     SLASH (/) - END OF NUMERATOR, DENOMINATOR FOLLOWS
	IF (LCH.EQ.LALSLH) GO TO 225
C     MINUS (-) - MAKE NN NEGATIVE
	IF (LCH.EQ.LALNEG)  XN=-1*XN
C     INVALID CHARACTER - IGNORE
	GO TO 245
225	RNUM(I)=XN
C     RESET COUNTER
235	XN=1.0
245	CONTINUE
255	NJ=J+1
265	CONTINUE
	RETURN
	END

