C**********************************************************************
C BRILLOUIN ZONE PLOT PROGRAM *
C PROGRAMED BY A.YANASE *
C MODIFIED BY H.FUNASHIMA,2003/12/11 *
C FOR G77 *
C**********************************************************************
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 WF/160.0,160.0,160.0/
DATA AF,BT,GM,ED,EL/-110.0,0.0,-15.0,150.0,150000.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)
XMAX=0.0
XMIN=0.0
DO 41 I=1,NLIN
DO 41 J=1,2
DO 41 K=1,3
IF(XMAX.LT.CO(K,J,I)) XMAX=CO(K,J,I)
IF(XMIN.GT.CO(K,J,I)) XMIN=CO(K,J,I)
41 CONTINUE
XMAX=XMAX*1.3D0
XMIN=XMIN*1.3D0
DO 43 K=1,3
XFU(K,1)=XMIN
XFU(K,2)=XMAX
43 CONTINUE
C
CALL AYPSTR(61)
CALL AYORIG(5.0,10.0)
CALL TPERSP(XFU,WF,AF,BT,GM,ED,EL)
CALL TPTRAC(1)
CALL TPHILP(-1.0D0)
CALL TPHILD(0.0D0,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 TPCIHL(5)
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,XS1,ZS1,XS2,ZS2
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)
XS1=XP
ZS1=ZP
CALL ZDMARK(10,'154',XS1,ZS1)
MMM=MK(1,I)
CALL CTYPE(XS1-3.0,ZS1,20,MMM)
CALL TPPOSI(X2,Y2,Z2,XP,ZP)
XS2=XP
ZS2=ZP
CALL ZDMARK(10,'154',XS2,ZS2)
MMM=MK(3,I)
CALL CTYPE(XS2-3.0,ZS2,20,MMM)
XS=(XS1+XS2)*0.5
ZS=(ZS1+ZS2)*0.5
MMM=MK(2,I)
CALL CTYPE(XS,ZS,18,MMM)
41 CONTINUE
RETURN
END
SUBROUTINE CTYPE(X,Y,IH,M)
C***********************************************************************
C WRITE NAMES OF POINTS AND AXES *
C***********************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
CHARACTER*4 D
REAL*4 X,Y,H
WRITE(D(1:2),'(A2)')M
K=2
X=X-2.5
IF(D(2:2).EQ.' ')K=1
IF(D(1:2).EQ.'GM') THEN
CALL GWRITE(IH,'G',X,Y)
ELSEIF(D(1:2).EQ.'XD') THEN
CALL CWRITE(IH,'X',1,X,Y)
ELSEIF(D(1:2).EQ.'SM') THEN
CALL GWRITE(IH,'S',X,Y)
ELSEIF(D(1:2).EQ.'LD') THEN
CALL GWRITE(IH,'L',X,Y)
ELSEIF(D(1:2).EQ.'DT') THEN
CALL GWRITE(IH,'D',X,Y)
else if(D(1:2).eq.'TP') then
CALL AWRITE(IH,"T'",2,X,Y,0)
else if(D(1:2).eq.'SP') then
CALL AWRITE(IH,"S'",2,X,Y,0)
ELSEIF(D(1:2).EQ.'MX') THEN
CALL CWRITE(IH,'M',1,X,Y)
ELSEIF(D(1:2).EQ.'LX') THEN
CALL CWRITE(IH,'L',1,X,Y)
ELSE
IF(K.EQ.1) CALL AWRITE(IH,D,K,X,Y,0)
ENDIF
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
C IF((ISO.EQ.1.OR.ISO.EQ.3).AND.NSPIN.NE.0) THEN
C WRITE(6,*) ' FOR PARAMAGNETIC BANDS NSPIN MUST BE 0',NSPIN
C STOP
C END IF
C IF(ISO.EQ.2.AND.(NSPIN.LE.0.OR.NSPIN.GT.3)) THEN
C WRITE(6,*) ' FOR FERROMAGNETIC BANDS'
C WRITE(6,*) ' NSPIN=1 ONLY FOR UP SPIN BANDS'
C WRITE(6,*) ' NSPIN=2 ONLY FOR DOWN SPIN BANDS'
C WRITE(6,*) ' NSPIN=3 FOR BOTH SPIN BANDS'
C STOP
C 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