IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION NRECPT(3,30),RECTAX(4,30),CO(3,2,100)
DIMENSION JB(2,3)
REAL*8 XFU(3,2),WF(3)
DATA XFU/-1.0,-1.0,-1.0,1.0,1.0,1.0/
DATA WF/200.0,200.0,200.0/
DATA AF,BT,GM,ED,EL/-110.0,0.0,-10.0,150.0,1500.0/
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,*) A,B,C
READ(1,*) CA,CB,CC
CALL TSLATC(A,B,C,CA,CB,CC)
CALL STRUCT
CALL TSBZEG(NRECPT,RECTAX,NRP,CO,NLIN)
C
CALL AYPSTR(61)
CALL AYORIG(30.0,30.0)
CALL TPERSP(XFU,WF,AF,BT,GM,ED,EL)
CALL TPTRAC(1)
CALL TPHILP(-1.0D0)
CALL TPHILD(0.0,1,6,5,0)
CALL LINEWD(1.1)
DO 42 I=1,NLIN
X1=CO(1,1,I)
Y1=CO(2,1,I)
Z1=CO(3,1,I)
X2=CO(1,2,I)
Y2=CO(2,2,I)
Z2=CO(3,2,I)
CALL TPLINE(X1,Y1,Z1,X2,Y2,Z2,80)
42 CONTINUE
CALL AXISPL
CALL AYPEND
STOP
END
SUBROUTINE AXISPL
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
COMMON/ISP/IX(NAXMAX),RT(NAXMAX),PS(2,NAXMAX),ICON(NAXMAX)
& ,MK(3,NAXMAX),NAXM
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX)
REAL*4 WD,XS,ZS
REAL*8 RECT(4,3)
INTEGER KG(3,3)
DATA KG/1,0,0, 0,1,0, 0,0,1/
CALL RECTAG(KG,RECT,3)
CALL TPHILD(0.0D0,0,5,3,1)
DO 41 I=1,NAXM
X1=RECT(1,1)*(DBLE(KK1M(1,I))/ICC1M(I))
X1=X1+RECT(1,2)*(DBLE(KK1M(2,I))/ICC1M(I))
X1=X1+RECT(1,3)*(DBLE(KK1M(3,I))/ICC1M(I))
Y1=RECT(2,1)*(DBLE(KK1M(1,I))/ICC1M(I))
Y1=Y1+RECT(2,2)*(DBLE(KK1M(2,I))/ICC1M(I))
Y1=Y1+RECT(2,3)*(DBLE(KK1M(3,I))/ICC1M(I))
Z1=RECT(3,1)*(DBLE(KK1M(1,I))/ICC1M(I))
Z1=Z1+RECT(3,2)*(DBLE(KK1M(2,I))/ICC1M(I))
Z1=Z1+RECT(3,3)*(DBLE(KK1M(3,I))/ICC1M(I))
X2=RECT(1,1)*(DBLE(KK2M(1,I))/ICC2M(I))
X2=X2+RECT(1,2)*(DBLE(KK2M(2,I))/ICC2M(I))
X2=X2+RECT(1,3)*(DBLE(KK2M(3,I))/ICC2M(I))
Y2=RECT(2,1)*(DBLE(KK2M(1,I))/ICC2M(I))
Y2=Y2+RECT(2,2)*(DBLE(KK2M(2,I))/ICC2M(I))
Y2=Y2+RECT(2,3)*(DBLE(KK2M(3,I))/ICC2M(I))
Z2=RECT(3,1)*(DBLE(KK2M(1,I))/ICC2M(I))
Z2=Z2+RECT(3,2)*(DBLE(KK2M(2,I))/ICC2M(I))
Z2=Z2+RECT(3,3)*(DBLE(KK2M(3,I))/ICC2M(I))
WD=1.0-I*0.01
CALL LINEWD(WD)
CALL TPLINE(X1,Y1,Z1,X2,Y2,Z2,30)
CALL TPPOSI(X1,Y1,Z1,XP,ZP)
XS=XP
ZS=ZP
CALL ZDMARK(10,'154',XS,ZS)
CALL TPPOSI(X2,Y2,Z2,XP,ZP)
XS=XP
ZS=ZP
CALL ZDMARK(10,'154',XS,ZS)
41 CONTINUE
RETURN
END
SUBROUTINE STRUCT
C***********************************************************************
C SELECTION OF POINTS TO BE PLOTTED *
C***********************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
COMMON/ISP/IX(NAXMAX),RT(NAXMAX),PS(2,NAXMAX),ICON(NAXMAX)
& ,MK(3,NAXMAX),NAXM
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX)
COMMON/SCL/WX,WY,EO,EM,XM,YM,IPR,ISO
DIMENSION KK1(3),KK2(3),KK3(3),MR(3),KTV(3),KG(3)
CHARACTER*2 CCR1,CCR2,CCR3
CHARACTER*4 CHARA4
CHARACTER*10 MAGNET
C
READ(3,150) MAGNET
150 format(A10)
CHARA4=MAGNET
IF(CHARA4.EQ.'NONM') ISO=1
IF(CHARA4.EQ.'MAGN') ISO=2
IF(CHARA4.EQ.'SPIN') ISO=3
READ(3,*) NLCOMP,NSPIN,IFILE
IF((ISO.EQ.1.OR.ISO.EQ.3).AND.NSPIN.NE.0) THEN
WRITE(6,*) ' FOR PARAMAGNETIC BANDS NSPIN MUST BE 0',NSPIN
STOP
END IF
IF(ISO.EQ.2.AND.(NSPIN.LE.0.OR.NSPIN.GT.3)) THEN
WRITE(6,*) ' FOR FERROMAGNETIC BANDS'
WRITE(6,*) ' NSPIN=1 ONLY FOR UP SPIN BANDS'
WRITE(6,*) ' NSPIN=2 ONLY FOR DOWN SPIN BANDS'
WRITE(6,*) ' NSPIN=3 FOR BOTH SPIN BANDS'
STOP
END IF
READ(3,*) IPR,JMARK,IPOINT
READ(3,*) EO,EM,YM,XM
WY=YM/(EM-EO)
C
PS(1,1)=0.0
NK=0
READ(3,*) NAXM
IF(NAXM.GT.NAXMAX) THEN
WRITE(6,*) ' NAXMAX=',NAXMAX,' NAXM=',NAXM
STOP
END IF
DO 99 NAX=1,NAXM
READ(3,*) (KK1(J),J=1,3),ICC1,(KK2(J),J=1,3),ICC2
IF(IPR.GE.2) WRITE(6,600) (KK1(J),J=1,3),ICC1,(KK2(J),J=1,3),ICC2
600 FORMAT( '(',3I4,')/',I4,'---','(',3I4,')/',I4)
C
DO 75 J=1,3
IIX=J
IF(KK1(J)*ICC2.NE.KK2(J)*ICC1) GOTO 81
75 CONTINUE
write(6,*) 'KK1 AND KK2 ARE THE SAME POINT'
STOP
81 IX(NAX)=IIX
DO 71 J=1,3
KK1M(J,NAX)=KK1(J)
KK2M(J,NAX)=KK2(J)
71 CONTINUE
ICC1M(NAX)=ICC1
ICC2M(NAX)=ICC2
KTV(1)=KK2(1)*ICC1-KK1(1)*ICC2
KTV(2)=KK2(2)*ICC1-KK1(2)*ICC2
KTV(3)=KK2(3)*ICC1-KK1(3)*ICC2
ICC=ICC1*ICC2
CALL ZZZY37(KTV(1),KTV(2),KTV(3),ICC,WW)
RT(NAX)=WW
BLK=0.0
ICON(NAX)=0
IF(NAX.NE.1) THEN
CALL EQUIKK(KK1,ICC1,KK3,ICC3,KG,IND)
IF(IND.EQ.0) THEN
ICON(NAX-1)=1
BLK=0.3*ABS(RT(1))
ENDIF
PS(1,NAX)=PS(2,NAX-1)+BLK
ENDIF
PS(2,NAX)=RT(NAX)+PS(1,NAX)
C IF(KTV(IIX).LT.0.) RT(NAX)=-RT(NAX)
IF(IPR.GE.2) WRITE(6,601) PS(1,NAX),PS(2,NAX),RT(NAX)
601 FORMAT(3F10.5)
DO 34 J=1,3
KK3(J)=KK2(J)
34 CONTINUE
ICC3=ICC2
KX=KK1(1)
KY=KK1(2)
KZ=KK1(3)
ICC=ICC1
CALL KPNAME(KX,KY,KZ,ICC,CCR1,KG)
READ(CCR1,'(A2)')MR(1)
MK(1,NAX)=MR(1)
KX=KK2(1)
KY=KK2(2)
KZ=KK2(3)
ICC=ICC2
CALL KPNAME(KX,KY,KZ,ICC,CCR3,KG)
READ(CCR3,'(A2)')MR(1)
MK(3,NAX)=MR(1)
KX=KK1(1)*ICC2+KK2(1)*ICC1
KY=KK1(2)*ICC2+KK2(2)*ICC1
KZ=KK1(3)*ICC2+KK2(3)*ICC1
ICC=ICC1*ICC2*2
CALL KPNAME(KX,KY,KZ,ICC,CCR2,KG)
READ(CCR2,'(A2)')MR(1)
MK(2,NAX)=MR(1)
IF(IPR.GE.2) WRITE(6,602) CCR1,CCR2,CCR3
602 FORMAT(3(3X,A2))
99 CONTINUE
WX=XM/PS(2,NAXM)
RETURN
END
FUNCTION FUNCD(XA)
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION XA(3)
XK=XA(1)
YK=XA(2)
ZK=XA(3)
CALL GETKVC(XK,YK,ZK,AK,BK,CK)
FUNCD=1.0D0
KX=1000000.0*AK
KY=1000000.0*BK
KZ=1000000.0*CK
CALL TSKFBZ(KX,KY,KZ,1000000,IND)
IF(IND.NE.0) FUNCD=-1.0D0
RETURN
END
FUNCTION LFUNC(XA)
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION XA(3)
LFUNC=-1
RETURN
END
function FUNC(XX)
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION XX(3)
FUNC=0.0
RETURN
END