IMPLICIT REAL*8(A-H,O-Z)
REAL*4 WIDTH,XSS,ZSS
INTEGER KKAT(100)
& ,JBO(2,10),NKO(30),IPT(10)
REAL*8 RB(30),RR(10)
REAL*8 WFF(3),XFU(3,2)
REAL*8 XXFU(3,2),XC(3,600),X1(3,600),X2(3,600)
& ,XOUT(3,30),BOL(30),VA(3,50)
REAL*8 XCC(3),R
INTEGER IK(300),JBB(2,600),IBB(600)
CHARACTER*1 CMARK(61)
DATA CMARK/'1','2','3','4','5','6','7','8','9','A',
& 'B','C','D','E','F','G','H','I','J','K','L',
& 'M','N','O','P','Q','R','S','T','U','V',
& 'W','X','Y','Z','a','b','c','d','e','f',
& 'g','h','i','j','k','l','m','n','o','p',
& 'q','r','s','t','u','v','w','x','y','z'/
CALL TSPPRP(NAT,NKA,KKAT)
READ(5,*) NBO
write(6,*) NBO
IF(NBO.GT.0) THEN
DO 4 I=1,NBO
READ(5,*) (JBO(J,I),J=1,2),BOL(I),RB(I)
4 CONTINUE
CALL TSBOGN(JBO,BOL,NBO,0)
JF=6
CALL TSBOVR(JF)
END IF
READ(5,*) (RR(I),I=1,NKA)
READ(5,*) (IPT(I),I=1,NKA)
READ(5,*) MA,MB,MC,KABC
READ(5,*) NOUT
IF(NOUT.NE.0) THEN
DO 5 I=1,NOUT
5 READ(5,*) (XOUT(J,I),J=1,3),NKO(I)
END IF
CALL TSCSDT(MA,MB,MC,KABC,XOUT,NKO,NOUT
& ,XXFU,XC,IK,NNS,JBB,IBB,NBB,X1,X2,NLINE)
write(6,*) ' NNS=',NNS,' NBB=',NBB
write(6,600) (IK(I),I=1,NNS)
write(6,600) (IBB(I),I=1,NBB)
write(6,600) ((JBB(J,I),J=1,2),I=1,NBB)
600 FORMAT(20I4)
READ(5,*) SIZE,AF,BT,GM,ED,EL
READ(5,*) ILF,IPOINT
RMAX=0.0
DO 10 I=1,NKA
IF(RMAX.LT.RR(I)) RMAX=RR(I)
10 CONTINUE
DO 31 I=1,3
XFU(I,1)=XXFU(I,1)*SIZE-RMAX
XFU(I,2)=XXFU(I,2)*SIZE+RMAX
31 CONTINUE
WFF(1)=XFU(1,2)-XFU(1,1)
WFF(2)=XFU(2,2)-XFU(2,1)
WFF(3)=XFU(3,2)-XFU(3,1)
CALL AYPSTR(ILF)
CALL AYORIG(10.0,10.0)
CALL TPERSP(XFU,WFF,AF,BT,GM,ED,EL)
CALL TPTRAC(1)
CALL TPCLEA
DO 51 I=1,NNS
JP=0
IF(IK(I).NE.0) JP=IPT(KKAT(IK(I)))
IF(IK(I).NE.0) R=RR(KKAT(IK(I)))
IF(IK(I).EQ.0) R=0.001
XCC(1)=XC(1,I)*SIZE
XCC(2)=XC(2,I)*SIZE
XCC(3)=XC(3,I)*SIZE
CALL TPSETS(XCC,R,JP)
IF(IK(I).NE.0.AND.IPOINT.NE.0) THEN
XA=XCC(1)
YA=XCC(2)
ZA=XCC(3)
CALL TPPOSI(XA,YA,ZA,XS,ZS)
XSS=XS
ZSS=ZS
CALL NRMARK(IPOINT,CMARK(IK(I)),XSS,ZSS)
END IF
51 CONTINUE
DO 52 I=1,NBB
R=RB(IBB(I))
J1=JBB(1,I)
J2=JBB(2,I)
CALL TPSETB(J1,J2,R)
52 CONTINUE
DO 53 I=1,NNS
IF(IK(I).NE.0) THEN
WIDTH=1.0D0+KKAT(IK(I))*0.01D0
WRITE(6,601) I,KKAT(IK(I)),WIDTH
CALL LINEWD(WIDTH)
JJ=I
CALL TPDRWS(JJ)
END IF
53 CONTINUE
DO 54 I=1,NBB
JJ=I
WIDTH=1.0D0-IBB(I)*0.01D0
WRITE(6,601) I,IBB(I),WIDTH
601 FORMAT(2I4,F6.2)
CALL LINEWD(WIDTH)
CALL TPDRWB(JJ)
54 CONTINUE
CALL LINEWD(1.0)
DO 55 I=1,NLINE
X11=X1(1,I)*SIZE
Y1=X1(2,I)*SIZE
Z1=X1(3,I)*SIZE
X22=X2(1,I)*SIZE
Y2=X2(2,I)*SIZE
Z2=X2(3,I)*SIZE
CALL TPLINE(X11,Y1,Z1,X22,Y2,Z2,191)
55 CONTINUE
CALL AYPEND
STOP
END
SUBROUTINE CLOCKM(ITIME)
C
C FOR UNIX
C
DIMENSION TERY(2)
C
C etime for AIX FORTRAN
CALL ETIME_(TERY)
C etime for SUN FORTARAN
C CALL ETIME(TERY)
ITIME=TERY(1)*1000
RETURN
END
SUBROUTINE PTIME(T)
REAL*8 T
CALL CLOCKM(IT)
T=IT/3600000.0
RETURN
END
FUNCTION FUNC(XX)
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION XX(3)
FUNC=0.0
RETURN
END
FUNCTION FUNCD(XA)
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION XA(3)
FUNCD=1.0
RETURN
END
FUNCTION LFUNC(XA)
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/BZPL/KKG(3,20),NNG,IEOH,INDC,IBR,ICUT
DIMENSION XA(3)
LFUNC=-1
RETURN
END
SUBROUTINE TSPPRP(NAT,NKAT,KKAT)
C***********************************************************************
C PREPERATION TO CALL TSPACE *
C***********************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/SCL/WX,WY,EO,EM,XM,YM,IPR,ISO
DIMENSION JB(2,3),KA(2,100),KION(100),KS(11,100),KKAT(100)
DIMENSION VA(3,100)
READ(1,*)
READ(1,*) IL,NGEN,INV
CALL TSPACE(IL)
DO 1 I=1,NGEN
READ(1,*) JA,((JB(J,K),J=1,2),K=1,3)
CALL TSGENR(JA,JB)
1 CONTINUE
CALL TSPGRP(INV)
CALL TSPGDS
READ(1,104) A,B,C
READ(1,104) CA,CB,CC
104 FORMAT(3D23.16)
CALL TSLATC(A,B,C,CA,CB,CC)
READ(1,120) NAT,NKAT,(KION(I),I=1,NKAT)
120 FORMAT(14I5)
J=0
DO 20 I=1,NKAT
JJ=J+1
DO 23 IA=JJ,KION(I)
KKAT(IA)=I
23 CONTINUE
KA(1,I)=JJ
KA(2,I)=KION(I)
J=KION(I)
20 CONTINUE
DO 2 I=1,NKA
DO 21 J=1,11
IF(J.NE.1) KS(J,I)=0
IF(J.EQ.1) KS(J,I)=1
21 CONTINUE
2 CONTINUE
DO 3 I=1,NAT
3 READ(1,*) (VA(J,I),J=1,3)
CALL TSCRST(VA,KA,NKAT,NAT,KS)
C RM=1.01D0
C CALL TSNBTB(RM,6)
RETURN
END