C SUBROUTINE TSCSDT ====*====3====*====4====*====5====*====6====*====7
C
C DATA FOR CRYSTAL STRUCTURE PLOT
C IN-PUT
C ATOMIC POSITIONS FOR NA*NB*NC UNIT CELLS
C IF(NA.EQ.0) THEN NC HEXAGONAL UNIT CELLS
C KABC=1,2,3,4,5,6 DETERMINE THE DIRECTION. SEE DATA OF I123
C XOUT(3,30) POSITION OF EXTRA ATOMS,
C NKO(30) NUMBERS OF EXTRA ATOMS IN TSCRST
C NOUT NUMBER OF EXTRA ATOMS
C OUT-PUT
C XFU(3,2) FIGURE SIZE IN UNIT OF LATTICE CONSTANT I123(1,KABC)
C IN RECTANGULAR COORDINATE.
C XC(3,300) CENTER OF SPHERES
C IK(300) NUMBERS OF ATOMS
C NNS NUMBER OF SPHERES
C JB(2,300) NUMBERS OF END SPHERES FOR BARS
C IBB(300) KINDS OF BONDS
C NBB NUMBER OF BARS
C X1(3,300),X2(3,300) END POINTS OF LINES
C NLINE NUMBER OF LINES
C
C 1989/12/19 AKIRA YANASE
C ORIGINAL PROGRAM IS TSLSPL
C
C---*----1----*----2----*----3----*----4----*----5----*----6----*----7
SUBROUTINE TSCSDT(NA,NB,NC,KABC,XOUT,NKO,NOUT
& ,XFU,XC,IK,NNS,JB,IBB,NBB,X1,X2,NLINE)
INCLUDE 'PARAM'
C PARAMETER (LMNATM=50,LMNKAT=10)
IMPLICIT REAL*8(A-H,O-Z)
COMPLEX*16 WWST,V
COMMON/SPG2/IL,NG,IG(48),JV(2,3,48)
COMMON/LAT/A,B,C,CA,CB,CC,A1,B1,C1
COMMON/ATT/ISITR(LMNATM,48),KION(LMNKAT),VATOM(3,LMNATM)
& ,NKATOM,NATOM,KS(11,LMNKAT),IA(LMNATM),JRCH
COMMON/BON/KBO(2,30),BOL(30),NBO,KBOND(4,200),NBOND,WWST(4000)
& ,IVEC(10000),VST(3,4000),NVEC,NDIM
& ,KA(2,1500),V(1500),INS(3,500),AA(500),NT,NS
SAVE /SPG2/,/LAT/,/BON/,/ATT/,I123
INTEGER I123(3,6)
DIMENSION XOUT(3,30),NKO(30)
REAL*8 XFU(3,2),XC(3,300),X1(3,300),X2(3,300)
INTEGER IK(300),JB(2,300),IBB(300)
DIMENSION N(3),II(3),X(3),XS(3,300),INNS(3,50)
DIMENSION WCOS(3),ABC(3),XA(3),XX(2,6)
DATA I123/
& 1,2,3, 1,3,2, 2,3,1, 2,1,3, 3,1,2, 3,2,1/
C ATOM POSITIONS
C
WRITE(6,*) ' POSITION OF SPHERES'
WRITE(6,*) ' NO COORDINATE IN A,B,C UNIT KIND NATOM'
NNS=0
N(1)=NA
N(2)=NB
N(3)=NC
IHEX=0
IF(NA.GT.0) GO TO 1001
IF(IL.GT.0) RETURN
IHEX=1
N(1)=2
N(2)=2
1001 CONTINUE
WRITE(6,6006) IL,IHEX,N
6006 FORMAT(10I5)
DO 100 IS=1,NATOM
INNS(1,IS)=NNS+1
DO 101 IAA=1,N(1)+2
II(1)=IAA-2
DO 102 IB=1,N(2)+2
II(2)=IB-2
DO 103 IC=1,N(3)+2
II(3)=IC-2
K=1
IF(IL.EQ.-1) K=3
IF(IL.EQ.2) K=4
IF(IL.EQ.3) K=2
IF(IL.EQ.4) K=2
DO 110 J=1, K
DO 111 I=1,3
W=VATOM(I,IS)
IF(J.EQ.1) GO TO 112
IF(IL.NE.-1) GO TO 113
W=W+1.0/3.0
IF(J.EQ.2.AND.I.EQ.1) W=W+1.0/3.0
IF(J.EQ.3.AND.I.NE.1) W=W+1.0/3.0
GO TO 112
113 IF(IL.EQ.3) W=W+0.5
IF(IL.EQ.2.AND.I.NE.J-1) W=W+0.5
IF(IL.EQ.4.AND.I.NE.3) W=W+0.5
112 W=W+II(I)
IF(W-N(I).GT.1.0E-4) GO TO 110
IF(W.LT.-1.0E-4) GO TO 110
X(I)=W
111 CONTINUE
IF(IHEX.EQ.0) GO TO 1002
IF(X(1)-X(2)-1.0.GT.1.0E-4) GO TO 110
IF(X(1)-X(2)+1.0.LT.-1.0E-4) GO TO 110
1002 CONTINUE
IF(NNS.GE.300) STOP
NNS=NNS+1
DO 114 I=1,3
114 XS(I,NNS)=X(I)
IK(NNS)=IS
WRITE(6,6001) NNS,X,IA(IS),IS
6001 FORMAT(I5,3F10.5,2I5)
110 CONTINUE
103 CONTINUE
102 CONTINUE
101 CONTINUE
INNS(3,IS)=NNS
IF(NOUT.EQ.0) GO TO 116
DO 115 I=1,NOUT
IF(NKO(I).NE.IS) GO TO 115
IF(NNS.GE.300) STOP
NNS=NNS+1
DO 117 K=1,3
117 XS(K,NNS)=XOUT(K,I)
IK(NNS)=IS
WRITE(6,6001) NNS,(XS(K,NNS),K=1,3),IA(IS),IS
115 CONTINUE
116 INNS(2,IS)=NNS
100 CONTINUE
NSS=NNS
C
C BARS BETWEEN ATOMS
C
NAB=NATOM*NATOM
NBB=0
WRITE(6,*) ' BARS BETWEEN SPHERE'
WRITE(6,*) ' NO END SPHERE BOND END POINT WITHOUT SPHERE'
DO 202 IS=1,NATOM
INS1=INNS(1,IS)
INS2=INNS(2,IS)
DO 203 IT=1,NATOM
ISIG=1
ISA=IS
ITA=IT
IF(IS.LE.IT) GO TO 214
ISIG=-1
ISA=IT
ITA=IS
214 CONTINUE
DO 201 IB=1,NBO
IF(KBO(1,IB).NE.IA(ISA)) GO TO 201
IF(KBO(2,IB).NE.IA(ITA)) GO TO 201
JNS1=INNS(1,IT)
JNS2=INNS(2,IT)
IN=(IB-1)*NAB+(ISA-1)*NATOM+ITA
IN1=MOD(IVEC(IN),10000)
IN2=IVEC(IN)/10000
IF(IN1.EQ.0) GO TO 201
DO 204 INSS=INS1,INS2
DO 205 I1N=IN1,IN2
DO 206 KK=1,3
XA(KK)=XS(KK,INSS)+VST(KK,I1N)*ISIG
206 CONTINUE
C WRITE(6,6002) I1N,INSS,IT,IS,IB,XA
C6002 FORMAT(5I5,3F10.5)
DO 207 JNS=JNS1,JNS2
DO 208 KK=1,3
IF(ABS(XA(KK)-XS(KK,JNS)).GT.1.0E-5) GO TO 207
208 CONTINUE
IF(IT.LT.IS) GO TO 205
IF(NBB.GE.300) STOP
NBB=NBB+1
JB(1,NBB)=INSS
JB(2,NBB)=JNS
IBB(NBB)=IB
WRITE(6,6003) NBB,(JB(I,NBB),I=1,2),IBB(NBB)
6003 FORMAT(4I5)
GO TO 205
207 CONTINUE
DO 209 KK=1,3
IF(XA(KK).GT.N(KK)+1.0E-4) GO TO 210
IF(XA(KK).GT.-1.0E-4) GO TO 209
IF(XS(KK,INSS).LT.1.0E-4) GO TO 205
WA=XS(KK,INSS)/(XS(KK,INSS)-XA(KK))
GO TO 211
210 IF(XS(KK,INSS).GT.N(KK)-1.0E-4) GO TO 205
WA=(N(KK)-XS(KK,INSS))/(XA(KK)-XS(KK,INSS))
211 DO 212 K=1,3
212 XA(K)=XS(K,INSS)+(XA(K)-XS(K,INSS))*WA
209 CONTINUE
IF(IHEX.EQ.0) GO TO 1003
IF(XA(1)-XA(2)-1.0.GT.1.0E-4) GO TO 2004
IF(XA(1)-XA(2)+1.0.GE.-1.0E-4) GO TO 1003
S=1.0
GO TO 2005
2004 S=-1.0
2005 WA=XA(2)-XS(2,INSS)-(XA(1)-XS(1,INSS))
W1=(XS(1,INSS)*XA(2)-XS(2,INSS)*XA(1)
& +S*(XA(1)-XS(1,INSS)))/WA
W2=W1+S
XA(3)=((XS(1,INSS)-XS(2,INSS))*XA(3)
& -(XA(1)-XA(2))*XS(3,INSS)+S*(XA(3)-XS(3,INSS)))/WA
XA(1)=W1
XA(2)=W2
1003 CONTINUE
IF(NNS.GE.300) STOP
NNS=NNS+1
DO 213 K=1,3
213 XS(K,NNS)=XA(K)
IK(NNS)=0
IF(NBB.GE.300) STOP
NBB=NBB+1
JB(1,NBB)=INSS
JB(2,NBB)=NNS
IBB(NBB)=IB
WRITE(6,6004) NBB,(JB(I,NBB),I=1,2),IBB(NBB),XA
6004 FORMAT(4I5,3F10.5)
205 CONTINUE
204 CONTINUE
201 CONTINUE
203 CONTINUE
202 CONTINUE
C
C COEFFICIENTS OF TRANSFORMATION
C
WCOS(1)=CA
WCOS(2)=CB
WCOS(3)=CC
ABC(1)=A
ABC(2)=B
ABC(3)=C
I1=I123(1,KABC)
I2=I123(2,KABC)
I3=I123(3,KABC)
WA=ABC(I1)
ABC(1)=ABC(1)/WA
ABC(2)=ABC(2)/WA
ABC(3)=ABC(3)/WA
WSIN=SQRT(1.0-WCOS(I3)**2)
F1=ABC(I1)
F2=ABC(I2)*WCOS(I3)
F3=ABC(I3)*WCOS(I2)
F4=ABC(I2)*WSIN
F5=ABC(I3)*(WCOS(I1)-WCOS(I2)*WCOS(I3))/WSIN
F6=ABC(I3)*SQRT(1.0-CA*CA-CB*CB-CC*CC
& +2.0*CA*CB*CC)/WSIN
C
C FIGURE SIZE
C
XFU(1,2)=DMAX1(F1*N(I1),F1*N(I1)+F2*N(I2),
& F1*N(I1)+F3*N(I3),F1*N(I1)+F2*N(I2)+F3*N(I3))
XFU(1,1)=DMIN1(0.0D0,F2*N(I2),F3*N(I3),F2*N(I2)+F3*N(I3))
XFU(2,2)=DMAX1(F4*N(I2),F4*N(I2)+F5*N(I3))
XFU(2,1)=DMIN1(0.0D0,F5*N(I3))
XFU(3,1)=0.0
XFU(3,2)=F6*N(I3)
IF(NOUT.EQ.0) GO TO 12
DO 11 I=1,NOUT
XO=F1*XOUT(I1,I)+F2*XOUT(I2,I)+F3*XOUT(I3,I)
IF(XO.GT.XFU(1,2)) XFU(1,2)=XO
IF(XO.LT.XFU(1,1)) XFU(1,1)=XO
YO=F4*XOUT(I2,I)+F5*XOUT(I3,I)
IF(YO.GT.XFU(2,2)) XFU(2,2)=YO
IF(YO.LT.XFU(2,1)) XFU(2,1)=YO
ZO=F6*XOUT(I3,I)
IF(ZO.GT.XFU(3,2)) XFU(3,2)=ZO
IF(ZO.LT.XFU(3,1)) XFU(3,1)=ZO
11 CONTINUE
12 CONTINUE
C
C TPERSP
C
DO 51 I=1,NNS
XC(1,I)=F1*XS(I1,I)+F2*XS(I2,I)+F3*XS(I3,I)
XC(2,I)=F4*XS(I2,I)+F5*XS(I3,I)
XC(3,I)=F6*XS(I3,I)
51 CONTINUE
NLINE=0
IF(IHEX.EQ.1) GO TO 1014
DO 1004 J1=1,N(I1)+1
DO 1005 J2=1,N(I2)+1
NLINE=NLINE+1
X1(1,NLINE)=F1*(J1-1)+F2*(J2-1)
X1(2,NLINE)=F4*(J2-1)
X1(3,NLINE)=0.0
X2(1,NLINE)=X1(1,NLINE)+F3*N(I3)
X2(2,NLINE)=X1(2,NLINE)+F5*N(I3)
X2(3,NLINE)=F6*N(I3)
1005 CONTINUE
1004 CONTINUE
DO 1006 J2=1,N(I2)+1
DO 1007 J3=1,N(I3)+1
NLINE=NLINE+1
X1(1,NLINE)=F2*(J2-1)+F3*(J3-1)
X1(2,NLINE)=F4*(J2-1)+F5*(J3-1)
X1(3,NLINE)=F6*(J3-1)
X2(1,NLINE)=X1(1,NLINE)+F1*N(I1)
X2(2,NLINE)=X1(2,NLINE)
X2(3,NLINE)=X1(3,NLINE)
1007 CONTINUE
1006 CONTINUE
DO 1008 J3=1,N(I3)+1
DO 1009 J1=1,N(I1)+1
NLINE=NLINE+1
X1(1,NLINE)=F1*(J1-1)+F3*(J3-1)
X1(2,NLINE)=F5*(J3-1)
X1(3,NLINE)=F6*(J3-1)
X2(1,NLINE)=X1(1,NLINE)+F2*N(I2)
X2(2,NLINE)=X1(2,NLINE)+F4*N(I2)
X2(3,NLINE)=X1(3,NLINE)
1009 CONTINUE
1008 CONTINUE
IF(IHEX.EQ.0) GO TO 1010
1014 CONTINUE
XX(1,1)=0.0
XX(2,1)=0.0
XX(1,2)=F1
XX(2,2)=0.0
XX(1,3)=F1*2.0+F2
XX(2,3)=F4
XX(1,4)=F1*2.0+F2*2.0
XX(2,4)=F4*2.0
XX(1,5)=F1+F2*2.0
XX(2,5)=F4*2.0
XX(1,6)=F2
XX(2,6)=F4
DO 1011 J1=1,N(3)+1
DO 1012 J2=1,6
JW=J2+1
IF(J2.EQ.6) JW=1
ZZ=(J1-1)*F6
NLINE=NLINE+1
X1(1,NLINE)=XX(1,J2)
X1(2,NLINE)=XX(2,J2)
X1(3,NLINE)=ZZ
X2(1,NLINE)=XX(1,JW)
X2(2,NLINE)=XX(2,JW)
X2(3,NLINE)=ZZ
1012 CONTINUE
1011 CONTINUE
DO 1013 J2=1,6
NLINE=NLINE+1
X1(1,NLINE)=XX(1,J2)
X1(2,NLINE)=XX(2,J2)
X1(3,NLINE)=0.0
X2(1,NLINE)=XX(1,J2)
X2(2,NLINE)=XX(2,J2)
X2(3,NLINE)=F6*N(I3)
1013 CONTINUE
1010 CONTINUE
RETURN
END