call tspprp
call enred(1,0)
call setaxs
call axenr(0,2,1)
call setpln
call plener(0,1)
do 1 i=1,6
nb=i
call splint(nb,1)
1 continue
write(6,*) ' rewind 3'
rewind 3
stop
end
SUBROUTINE SPLINT(IB,IUOD)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (N65=129,maxplp=n65*n65,maxpnt=n65*(n65+1)*(n65+2)/6)
PARAMETER (NAXMAX=20)
PARAMETER (MAXKPT=1000,MAXEIG=16)
PARAMETER (MAXFKP=300,MAXIRP=33)
CHARACTER*2 MRRM
COMMON/AXE/EAX(N65,MAXEIG,MAXIRP),NKPT(MAXIRP)
& ,NLIN(MAXIRP),JRR(MAXIRP),JUD(MAXIRP),IRRM(MAXIRP),NAXEN
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ixxm(naxmax),naxm
COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
& ,MRRM(MAXKPT),MRNM(MAXKPT),MWEIM(MAXKPT),NSTM(MAXKPT)
& ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT
common/plend/kpl(3,7,2),icpl,iedg(6,2),nplane
COMMON/PLE/EPL(maxplp,maxeig,4),irpm(4),nplm(4)
DIMENSION ENRR(maxpnt),NM1(n65)
DIMENSION NM(n65),X(n65),Y(n65),SM(n65),XX(n65),YY(n65),IEN(n65)
INTEGER Q,R,Q49
DO 9 I=1,maxpnt
9 ENRR(I)=99.
NB=IB
DO 1 I=1,2
DO 2 IX=1,n65
iyend=ix
if(i.eq.2) iyend=n65
DO 3 IY=1,iyend
if(i.eq.1) THEN
N2=(IX*(IX-1))/2+IY
N3=((IX-1)*IX*(IX+1))/6+(IY*(IY-1))/2+1
JX=N65
JY=N65-IY+1
JZ=N65-IX+1
N31=((JX-1)*JX*(JX+1))/6+(JY*(JY-1))/2+JZ
else if(i.eq.2) THEN
N2=n65*(ix-1)+iy
if(ix.ge.iy) N3=((IX-1)*IX*(IX+1))/6+(Iy*(Iy-1))/2+IY
if(ix.lt.iy) N3=((Iy-1)*Iy*(Iy+1))/6+(IY*(IY-1))/2+Ix
end if
C ENRR(n3)=epl(n2,nb,i)
I1=1
I2=1
DO 4 J=1,NB
IF(EPL(N2,I1,I*2-1).GT.EPL(N2,I2,I*2)) GO TO 5
IF(J.EQ.NB) THEN
ENRR(N3)=EPL(N2,I1,I*2-1)
IF(I.EQ.1) ENRR(N31)=ENRR(N3)
END IF
I1=I1+1
GO TO 4
5 IF(J.EQ.NB) THEN
ENRR(N3)=EPL(N2,I2,I*2)
IF(I.EQ.1) ENRR(N31)=ENRR(N3)
END IF
I2=I2+1
4 CONTINUE
3 CONTINUE
2 CONTINUE
1 CONTINUE
C Q-axis
IZ=0
IY=(N65-1)/2+1
DO 6 I=1,N65,2
IZ=IZ+1
IX=N65-IZ+1
N3=((IX-1)*IX*(IX+1))/6+(IY*(IY-1))/2+IZ
DO 61 j=nlin(17)+1,maxeig
eax(i,j,17)=99.9
61 continue
DO 62 j=nlin(18)+1,maxeig
eax(i,j,18)=99.9
62 continue
I1=1
I2=1
DO 7 J=1,NB
C if(nb.eq.12) write(6,6601) j,i1,i2
C & ,eax(i,i1,14),eax(i,i2,15)
C 6601 FORMAT(3i5,2f8.4)
IF(EAX(I,I1,17).GT.EAX(I,I2,18)) go to 8
IF(J.EQ.NB) ENRR(N3)=EAX(I,I1,17)
I1=I1+1
GO TO 7
8 IF(J.EQ.NB) ENRR(N3)=EAX(I,I2,18)
I2=I2+1
7 CONTINUE
write(6,6600) ix,iy,iz,n3,i1-1,i2-1
& ,enrr(n3),eax(i,i1-1,17),eax(i,i2-1,18)
6600 format(3i4,i6,2i3,3f8.4)
6 CONTINUE
do 40 i=1,nkpint
if(iuod.ne.iudm(i)) go to 40
do 41 j=1,3
if(kxm(j,i).eq.0.or.kxm(j,i).eq.icm(i)) go to 40
41 continue
if(kxm(1,i).eq.kxm(2,i)) go to 40
if(kxm(2,i).eq.kxm(3,i)) go to 40
if(kxm(1,i).eq.kxm(3,i)) go to 40
if(2*kxm(2,i).eq.icm(i)
& .and.(kxm(1,i)+kxm(3,i)).eq.icm(i)) go to 40
IX=KXm(1,i)*((n65-1))/icm(i)+1
Iy=KXm(2,i)*((n65-1))/icm(i)+1
Iz=KXm(3,i)*((n65-1))/icm(i)+1
N3=((IX-1)*IX*(IX+1))/6+(IY*(IY-1))/2+IZ
ENRR(N3)=EIGM(NB,i)
JX=N65-IZ+1
JY=N65-IY+1
JZ=N65-IX+1
N32=((JX-1)*JX*(JX+1))/6+(JY*(JY-1))/2+JZ
ENRR(N32)=EIGM(NB,I)
write(6,6000) ix,iy,iz,jx,jy,jz,n3,n32,ENRR(n3)
6000 format(3i3,2x,3i3,2i6,f8.4)
40 continue
C
C INTERPOLATION STATRS
C
DO 129 R=1,4
Q=2**(5-R)
C R 1 2 3 4
C Q 16 8 4 2
C Q49 21 41 81 161
DO 120 I=1,4
C if(r.ne.1.and.i.eq.1) go to 120
if(i.eq.1) then
ixst=2*q+1
iyst=q+1
else if(i.eq.2) then
ixst=3*(q/2)+1
iyst=q+1
else if(i.eq.3) then
ixst=q+1
iyst=q/2+1
else if(i.eq.4) then
ixst=3*(q/2)+1
iyst=q/2+1
end if
write(6,*) r,q,i,ixst,iyst
do 121 ix=ixst,n65,Q
if(ix.eq.n65) go to 121
do 122 iy=iyst,ix,q
if(iy.eq.ix) go to 122
MM=0
K=0
q49=0
DO 102 IZ=1,n65,q/2
q49=q49+1
K=K+1
JX=IX
JY=IY
JZ=IZ
IF(IZ.LE.JY) GO TO 103
JZ=JY
JY=IZ
103 IF(IZ.LE.JX) GO TO 104
JY=JX
JX=IZ
104 NM(K)=((JX-1)*JX*(JX+1))/6+(JY*(JY-1))/2+JZ
C WRITE(6,601) IZ,JX,JY,JZ
JXX=N65-JZ+1
JYY=N65-JY+1
JZZ=N65-JX+1
NM1(K)=((JXX-1)*JXX*(JXX+1))/6+(JYY*(JYY-1))/2+JZZ
XX(K)=IZ-1
IF(ENRR(NM(K)).GT.90.) GO TO 102
MM=MM+1
X(MM)=IZ-1
Y(MM)=ENRR(NM(K))
102 CONTINUE
C WRITE(6,601) NB,IX,IY,MM,Q49
IF(MM.LT.3) GO TO 121
IF(MM.GE.Q49) GO TO 121
C WRITE(6,601) (NM(K),K=1,Q49)
601 FORMAT(8I8)
C WRITE(6,600) (ENRR(NM(K)),K=1,Q49)
600 FORMAT(8F8.4)
CALL S3N(X,Y,SM,XX,YY,MM,Q49,0.0d0,0.0d0,0.0d0,0.0d0)
DO 106 K=1,Q49
ENRR(NM1(K))=YY(K)
106 ENRR(NM(K))=YY(K)
C DO 107 K=1,Q49
C 107 IEN(K)=INT((ENRR(NM(K))-ENRR(NM(K-1)))*10000)
C IEN(1)=INT(ENRR(NM(1))*10000)
C WRITE(6,603) (IEN(K),K=1,Q49)
C WRITE(6,600) (ENRR(NM(K)),K=1,Q49)
122 continue
121 continue
120 CONTINUE
129 CONTINUE
IXMAX=n65
NNEE=maxpnt
WRITE(3) IXMAX,NB,NNEE
WRITE(3) (ENRR(K),K=1,NNEE)
C 300 FORMAT(3I7)
C 301 FORMAT(8F12.)
WRITE(6,660) NB
660 FORMAT(1H1,' ENERGIES FOR BAND',I4)
DO 130 I=1,n65,2
WRITE(6,661) I
661 FORMAT(' IX=',I3)
DO 131 J=1,I,2
NN=((I-1)*I*(I+1))/6+(J*(J-1))/2
DO 132 K=1,J
IEN(K)=INT(ENRR(NN+K)*10000+0.5)
IF(ENRR(NN+K).LE.-0.5) IEN(K)=IEN(K)-1
132 CONTINUE
WRITE(6,603) (IEN(K),K=1,J,2)
C WRITE(6,603) (INT(ENRR(K)*10000+0.5),K=NN+1,NN+J)
603 FORMAT(30I5)
131 CONTINUE
130 CONTINUE
WRITE(6,662)
662 FORMAT(' ENERGIES IN XY-PLANE')
DO 133 I=1,n65,2
DO 134 J=1,n65,2
IF(J.LE.I) NN=((I-1)*I*(I+1))/6+(J*(J-1))/2+J
IF(J.GT.I) NN=((J-1)*J*(J+1))/6+(J*(J-1))/2+I
IEN(J)=INT(ENRR(NN)*10000+0.5)
IF(ENRR(NN).LE.-0.0005) IEN(J)=IEN(J)-1
134 CONTINUE
WRITE(6,603) (IEN(J),J=1,N65,2)
133 CONTINUE
WRITE(6,663)
663 FORMAT(' ENERGIES IN Z-PLANE')
DO 135 I=1,n65,2
DO 136 J=1,I
N=((I-1)*I*(I+1))/6+(J*(J-1))/2+1
IEN(J)=INT(ENRR(N)*10000+0.5)
IF(ENRR(N).LE.-0.5) IEN(J)=IEN(J)-1
136 CONTINUE
WRITE(6,603) (IEN(J),J=1,I,2)
135 CONTINUE
RETURN
END
SUBROUTINE TSPPRP
C***********************************************************************
C PREPERATION TO CALL TSPACE *
C***********************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION JB(2,3)
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)
C 102 FORMAT(14I5)
C READ(1,102) NATOM,NKAT
C NK=NKAT
C CALL ENRRED(2,NK)
C PRINT ,' END OF ENRRED'
C IF(IPR.GE.4)CALL ENERDS(6)
RETURN
END
SUBROUTINE ENRED(NLCOMP,idob)
PARAMETER (MAXKPT=1000,MAXEIG=16)
IMPLICIT REAL*8 (A-H,O-Z)
CHARACTER*2 MRR,MRRM
COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
& ,MRRM(MAXKPT),MRNM(MAXKPT),MWEIM(MAXKPT),NSTM(MAXKPT)
& ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT
DIMENSION KX(3),KBbb(3,10),KG(3,10),KBB(3),itcr(12)
dimension eig(200)
REWIND 2
C
N=0
40 READ(2,150,END=41) KK,(KX(J),J=1,3),IC,IUD,MRR,MRN,MWEI,NST,NEIG
C write(6,150) KK,(KX(J),J=1,3),IC,IUD,MRR,MRN,MWEI,NST,NEIG
IF(NEIG.GT.200) THEN
WRITE(6,*) ' MAXEIG=',MAXEIG,' NEIG=',NEIG
STOP
END IF
IF(NEIG.GT.0) READ(2,*) (EIG(J),J=1,NEIG)
150 FORMAT(I3,2X,3I3,1X,2I3,2X,A2,I2,3I3)
C 151 FORMAT(8F8.4)
IF(NEIG.EQ.0) GO TO 40
IF(NLCOMP.NE.0) THEN
NFACT=(NLCOMP-1)/2+1
DO 50 K=1,NEIG*NFACT
50 READ(2,*)
END IF
N=N+1
IF(N.GT.MAXKPT) THEN
WRITE(6,*) ' MAXKPT=',MAXKPT,' NKPINT=',N
STOP
END IF
CALL NEAREC(KX,IC,KBbb,KG,NG)
do 11 j=1,3
kbb(j)=iabs(kbbb(j,1))
11 continue
if(kbb(2).lt.kbb(3)) then
kwork=kbb(2)
kbb(2)=kbb(3)
kbb(3)=kwork
end if
if(kbb(1).lt.kbb(2)) then
kwork=kbb(2)
kbb(2)=kbb(1)
kbb(1)=kwork
end if
if(kbb(2).lt.kbb(3)) then
kwork=kbb(2)
kbb(2)=kbb(3)
kbb(3)=kwork
end if
DO 10 J=1,3
KXM(J,N)=KBB(J)
10 CONTINUE
call corres(kx,ic,kbb,ic,idob,itcr,nrr,ind)
if(ind.eq.0) then
write(6,*) ' STOP IN ENRED'
stop
end if
ICM(N)=IC
C write(6,*) n,(kxm(j,n),j=1,3),icm(n)
IUDM(N)=IUD
MRRM(N)=MRR
MRNM(N)=itcr(MRN)
MWEIM(N)=MWEI
NSTM(N)=NST
JJ=0
DO 20 J=1,NEIG
EIGM(J,N)=EIG(J)
20 CONTINUE
21 NEIGM(N)=NEIG
GO TO 40
41 CONTINUE
NKPINT=N
RETURN
END
SUBROUTINE setaxs
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
common/spg2/il,ng,ig(48),jv(2,3,48)
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ix(naxmax),naxm
integer kfcc(3,2,5)/0,0,0, 1,0,0, 0,0,0, 1,1,0,
& 0,0,0, 1,1,1, 2,0,0, 2,1,0,
& 2,1,0, 1,1,1/
integer icfcc(5)/1, 1, 2, 2, 2/
integer ixfcc(5)/1, 1, 1, 2, 3/
C
if(il.eq.2) then
naxm=5
do 1 i=1,naxm
do 3 k=1,3
kk1m(k,i)=kfcc(k,1,i)
kk2m(k,i)=kfcc(k,2,i)
3 continue
ix(i)=ixfcc(i)
icc1m(i)=icfcc(i)
icc2m(i)=icfcc(i)
1 continue
else
write(6,*) ' STOP in SETAXS'
stop
ENDIF
RETURN
END
SUBROUTINE AXENR(JDOUB,IPR,NSPIN)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
PARAMETER (MAXKPT=1000,MAXEIG=16)
PARAMETER (MAXFKP=300,MAXIRP=33)
PARAMETER (N65=129)
CHARACTER*2 MRRM
COMMON/AXE/EAX(N65,MAXEIG,MAXIRP),NKPT(MAXIRP)
& ,NLIN(MAXIRP),JRR(MAXIRP),JUD(MAXIRP),IRRM(MAXIRP),NAXEN
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ix(naxmax),naxm
COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
& ,MRRM(MAXKPT),MRNM(MAXKPT),MWEIM(MAXKPT),NSTM(MAXKPT)
& ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT
DIMENSION KB(3),JTR(12),IPA(12),ND(12)
DIMENSION NRECPT(3,20)
JD=JDOUB
NAXEN=0
DO 11 I=1,NAXM
II=I
IF(IPR.GE.2) WRITE(6,601) II
601 FORMAT(' RECFND',I3)
CALL RECFND(II,NRECPT,NRPT,IPR)
IF(IPR.GE.2) WRITE(6,602) II,NRPT
602 FORMAT(' KPFIEN',I3,' NUMBER OF RECPR. LAT. POINTS=',I3)
CALL KPFIEN(II,NRECPT,NRPT,IPR)
DO 21 K=1,3
KB(K)=KK1M(K,I)*ICC2M(I)+KK2M(K,I)*ICC1M(I)
21 CONTINUE
IC=ICC1M(I)*ICC2M(I)*2
CALL TSIREP(KB,IC,JD)
CALL DGTRST(JDO,NR,NH,NSTR,ND,JTR,IPA)
IF(IPR.GE.2) WRITE(6,603) KB,IC
603 FORMAT(' CMPTBL (',3I3,')/',I4)
CALL CMPTBL(JD,II,KB,IC,NR,NH,IPR)
DO 22 IR=1,NR
IF(JTR(IR).EQ.0.AND.IPA(IR).LT.IR) GO TO 22
IIR=IR
NAXEN=NAXEN+1
IF(NAXEN.GT.MAXIRP) THEN
WRITE(6,*) ' MAXIRP=',MAXIRP,' NAXEN=',NAXEN
STOP
END IF
IF(NSPIN.NE.2) IUD=1
IF(NSPIN.EQ.2) IUD=2
CALL INTPOR(JD,II,KB,IC,NH,IIR,IUD,IPR)
JUD(NAXEN)=IUD
IF(NSPIN.EQ.3) THEN
NAXEN=NAXEN+1
IF(NAXEN.GT.MAXIRP) THEN
WRITE(6,*) ' MAXIRP=',MAXIRP,' NAXEN=',NAXEN
STOP
END IF
IUD=2
CALL INTPOR(JD,II,KB,IC,NH,IIR,IUD,IPR)
JUD(NAXEN)=IUD
END IF
22 CONTINUE
11 CONTINUE
RETURN
END
SUBROUTINE RECFND(II,NRECPT,NRPT,IPR)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
C
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ix(naxmax),naxm
C
DIMENSION KB(3),NRECPT(3,20),KG(3,10),KBB(3,10)
JJ=0
DO 10 J=1,4
IF(J.EQ.1) THEN
DO 11 K=1,3
KB(K)=2*KK1M(K,II)*ICC2M(II)-KK2M(K,II)*ICC1M(II)
11 CONTINUE
ICC=ICC2M(II)*ICC1M(II)
ELSE IF(J.EQ.2) THEN
DO 12 K=1,3
KB(K)=KK1M(K,II)
12 CONTINUE
ICC=ICC1M(II)
ELSE IF(J.EQ.3) THEN
DO 13 K=1,3
KB(K)=KK2M(K,II)
13 CONTINUE
ICC=ICC2M(II)
ELSE IF(J.EQ.4) THEN
DO 14 K=1,3
KB(K)=2*KK2M(K,II)*ICC1M(II)-KK1M(K,II)*ICC2M(II)
14 CONTINUE
ICC=ICC1M(II)*ICC2M(II)
END IF
CALL NEAREC(KB,ICC,KBB,KG,NNG)
DO 16 N=1,NNG
IF(JJ.EQ.0) GO TO 17
DO 18 IJ=1,JJ
DO 19 K=1,3
IF(KG(K,N).NE.NRECPT(K,IJ)) GO TO 18
19 CONTINUE
GO TO 16
18 CONTINUE
17 JJ=JJ+1
DO 15 K=1,3
NRECPT(K,JJ)=KG(K,N)
15 CONTINUE
IF(IPR.GE.4) WRITE(6,601) II,J,JJ,(NRECPT(K,JJ),K=1,3)
601 FORMAT(6I5)
16 CONTINUE
10 CONTINUE
NRPT=JJ
RETURN
END
SUBROUTINE KPFIEN(II,NRECPT,NRPT,IPR)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
PARAMETER (MAXKPT=1000,MAXEIG=16)
PARAMETER (MAXFKP=300,MAXIRP=33)
CHARACTER*2 MRRM
C
COMPLEX*16 CW
COMMON/SPG2/IL,NG,IG(48),JV(2,3,48)
COMMON/STK/KS(3,48),JS(48),NS,ICBB,CW(48,12)
C
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ix(naxmax),naxm
COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
& ,MRRM(MAXKPT),MRNM(MAXKPT),MWEIM(MAXKPT),NSTM(MAXKPT)
& ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT
COMMON/AXP/IFKP(MAXFKP),JSKP(MAXFKP),KKB(3,MAXFKP)
& ,ICCB(MAXFKP),ICPTBL(12,MAXFKP),INDM(MAXFKP),NPOINT
C
DIMENSION KB(3),KBC(3)
DIMENSION NRECPT(3,20),JIND(MAXKPT),IMM(MAXKPT)
C
CALL ADDINV(NTLATC)
X1=DBLE(KK1M(1,II))/ICC1M(II)
Y1=DBLE(KK1M(2,II))/ICC1M(II)
Z1=DBLE(KK1M(3,II))/ICC1M(II)
DX=DBLE(KK2M(1,II))/ICC2M(II)-X1
DY=DBLE(KK2M(2,II))/ICC2M(II)-Y1
DZ=DBLE(KK2M(3,II))/ICC2M(II)-Z1
C write(6,*) x1,y1,z1
C write(6,*) dx,dy,dz
D6=1.0D-6
NPOINT=0
DO 10 I=1,NKPINT
JIND(I)=0
10 CONTINUE
DO 1 I=1,NKPINT
IF(JIND(I).NE.0) GO TO 1
KB(1)=KXM(1,I)
KB(2)=KXM(2,I)
KB(3)=KXM(3,I)
IC=ICM(I)
c write(6,*) 'kb',kb,ic
NJ=1
IMM(1)=I
IF(I.LE.NKPINT) THEN
DO 4 JI=I+1,NKPINT
IF(JIND(JI).NE.0) GO TO 4
DO 5 K=1,3
IF(KB(K)*ICM(JI).NE.KXM(K,JI)*IC) GO TO 4
5 CONTINUE
NJ=NJ+1
IMM(NJ)=JI
4 CONTINUE
END IF
C-----------------------------------------
C STAR OF K IS OBTAINED
CALL TSIREP(KB,IC,0)
CALL ZZZY38
C------------------------------------------
DO 2 J=1,NS
c write(6,*) j,(ks(k,j),k=1,3),icbb
DO 3 KGG=1,NRPT
XK=DBLE(KS(1,J))/ICBB+DBLE(NRECPT(1,KGG))
YK=DBLE(KS(2,J))/ICBB+DBLE(NRECPT(2,KGG))
ZK=DBLE(KS(3,J))/ICBB+DBLE(NRECPT(3,KGG))
c write(6,*) xk,yk,zk
IF(DABS(DX).LE.D6.AND.DABS(XK-X1).GT.D6) GO TO 3
IF(DABS(DY).LE.D6.AND.DABS(YK-Y1).GT.D6) GO TO 3
IF(DABS(DZ).LE.D6.AND.DABS(ZK-Z1).GT.D6) GO TO 3
IF(DABS(DX).GT.D6) THEN
IF(DABS(DY).GT.D6) THEN
IF(DABS((XK-X1)/DX-(YK-Y1)/DY).GT.D6) GO TO 3
END IF
IF(DABS(DZ).GT.D6) THEN
IF(DABS((XK-X1)/DX-(ZK-Z1)/DZ).GT.D6) GO TO 3
END IF
END IF
IF(DABS(DY).GT.D6.AND.DABS(DZ).GT.D6) THEN
IF(DABS((YK-Y1)/DY-(ZK-Z1)/DZ).GT.D6) GO TO 3
END IF
IF(IX(II).EQ.1.AND.
& ((XK-X1)/DX.LT.-1.0D0.OR.(XK-X1)/DX.GT.2.0D0)) GO TO 3
IF(IX(II).EQ.2.AND.
& ((YK-Y1)/DY.LT.-1.0D0.OR.(YK-Y1)/DY.GT.2.0D0)) GO TO 3
IF(IX(II).EQ.3.AND.
& ((ZK-Z1)/DZ.LT.-1.0D0.OR.(ZK-Z1)/DZ.GT.2.0D0)) GO TO 3
KBC(1)=KS(1,J)+NRECPT(1,KGG)*ICBB
KBC(2)=KS(2,J)+NRECPT(2,KGG)*ICBB
KBC(3)=KS(3,J)+NRECPT(3,KGG)*ICBB
IF(NPOINT.EQ.0) GO TO 20
DO 21 N=1,NPOINT
DO 22 K=1,3
IF(KBC(K)*ICCB(N).NE.KKB(K,N)*ICBB) GO TO 21
22 CONTINUE
IF(MRNM(IFKP(N)).EQ.MRNM(I)) GO TO 3
21 CONTINUE
20 DO 6 JI=1,NJ
JIND(IMM(JI))=I
NPOINT=NPOINT+1
IF(NPOINT.GT.MAXFKP) THEN
WRITE(6,*) ' MAXFKP=',MAXFKP,' NPOINT=',NPOINT
STOP
END IF
IFKP(NPOINT)=IMM(JI)
JSKP(NPOINT)=JS(J)
KKB(1,NPOINT)=KBC(1)
KKB(2,NPOINT)=KBC(2)
KKB(3,NPOINT)=KBC(3)
ICCB(NPOINT)=ICBB
IF(IPR.GE.4) THEN
N=NPOINT
WRITE(6,601) N,KBC,ICBB,IFKP(N)
& ,KB,IC,MRRM(IFKP(N)),MRNM(IFKP(N))
601 FORMAT(I3,'(',3I4,')/',I4,I3,
& '(',3I3,')/',I3,2X,A2,I3)
END IF
6 CONTINUE
c write(6,*) xk,yk,zk
c write(6,*) npoint,kbc,icbb,i,j,kgg
3 CONTINUE
2 CONTINUE
1 CONTINUE
CALL REMINV
RETURN
END
SUBROUTINE CMPTBL(JD,II,KBB,ICC,NRT,NH,IPR)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
PARAMETER (MAXKPT=1000,MAXEIG=16)
PARAMETER (MAXFKP=300,MAXIRP=33)
PARAMETER (N65=129)
CHARACTER*2 MRRM
COMMON/AXE/EAX(N65,MAXEIG,MAXIRP),NKPT(MAXIRP)
& ,NLIN(MAXIRP),JRR(MAXIRP),JUD(MAXIRP),IRRM(MAXIRP),NAXEN
COMMON/AXP/IFKP(MAXFKP),JSKP(MAXFKP),KKB(3,MAXFKP)
& ,ICCB(MAXFKP),ICPTBL(12,MAXFKP),INDM(MAXFKP),NPOINT
COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
& ,MRRM(MAXKPT),MRNM(MAXKPT),MWEIM(MAXKPT),NSTM(MAXKPT)
& ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT
C
DIMENSION KB(3),KBX(3),KBB(3)
DIMENSION ITCR(12),ND(12),JTR(12),IPA(12)
DIMENSION NDX(12),JTRX(12),IPAX(12)
DIMENSION ICP(12,12),ICP0(12,12)
C
JDOB=JD
DO 11 I=1,NPOINT
INDM(I)=0
11 CONTINUE
DO 1 I=1,NPOINT
IF(INDM(I).NE.0) GO TO 1
KB(1)=KKB(1,I)
KB(2)=KKB(2,I)
KB(3)=KKB(3,I)
IC=ICCB(I)
KBX(1)=KXM(1,IFKP(I))
KBX(2)=KXM(2,IFKP(I))
KBX(3)=KXM(3,IFKP(I))
ICX=ICM(IFKP(I))
CALL CORRES(KB,IC,KBX,ICX,JDOB,ITCR,NRR,IND)
IF(IND.EQ.0) THEN
write(6,*) ' kb=',kb,iv,' kbx=',kbx,icx
WRITE(6,*) ' STOP AT CORRES IN CMPTBL'
STOP
END IF
CALL TSIREP(KBX,ICX,JDOB)
CALL DGTRST(JDO,NRX,NHX,NSTRX,NDX,JTRX,IPAX)
CALL TSIREP(KB,IC,JDOB)
CALL DGTRST(JDO,NRR,NHH,NSTR,ND,JTR,IPA)
DO 4 IR1=1,NRX
IF(JTR(IR1).EQ.0.AND.IR1.LT.IPAX(IR1).AND.
& ITCR(IR1).GT.IPA(ITCR(IR1))) THEN
IW1=ITCR(IR1)
ITCR(IR1)=ITCR(IPAX(IR1))
ITCR(IPAX(IR1))=IW1
END IF
4 CONTINUE
C write(6,*) ' cor',kb,ic,kbx,icx,(itcr(L),L=1,nrr)
IF(NH.NE.NHH) THEN
CALL COMPAT(KBB,ICC,NRTT,KB,IC,NRR,JDOB,ICP,INDC)
C write(6,*) kbb,icc,kb,ic
C do 1000 i1=1,nrt
C write(6,*) ' icp',(icp(L,i1),L=1,nrr)
C 1000 continue
IF(INDC.NE.0) THEN
WRITE(6,*) 'STOP AT COMPAT IN COMTBL'
STOP
END IF
CALL CMPTRV(KBB,ICC,KB,IC,JDOB,ICP,ICP0)
C do 1001 i1=1,nrt
C write(6,*) ' icp0',(icp0(L,i1),L=1,nrr)
C 1001 continue
DO 2 IIR=1,NRT
ICPTBL(IIR,I)=ICP0(ITCR(MRNM(IFKP(I))),IIR)
2 CONTINUE
INDM(I)=1
IF(IPR.GE.4) WRITE(6,601) I,INDM(I),(ICPTBL(K,I),K=1,NRT)
601 FORMAT(14I3)
IF(I.EQ.NPOINT) GO TO 1
DO 20 J=I+1,NPOINT
DO 22 K=1,3
IF(KB(K)*ICCB(J).NE.KKB(K,J)*IC) GO TO 1
22 CONTINUE
DO 23 IIR=1,NRT
ICPTBL(IIR,J)=ICP0(ITCR(MRNM(IFKP(J))),IIR)
23 CONTINUE
INDM(J)=1
IF(IPR.GE.4)
& WRITE(6,601) J,INDM(J),(ICPTBL(K,J),K=1,NRT)
20 CONTINUE
ELSE
DO 3 IIR=1,NRT
ICPTBL(IIR,I)=0
3 CONTINUE
ICPTBL(ITCR(MRNM(IFKP(I))),I)=1
INDM(I)=-1
IF(IPR.GE.4)
& WRITE(6,601) I,INDM(I),(ICPTBL(K,I),K=1,NRT)
IF(I.EQ.NPOINT) GO TO 1
DO 30 J=I+1,NPOINT
DO 32 K=1,3
IF(KB(K)*ICCB(J).NE.KKB(K,J)*IC) GO TO 1
32 CONTINUE
DO 33 IIR=1,NRT
ICPTBL(IIR,J)=0
33 CONTINUE
ICPTBL(ITCR(MRNM(IFKP(J))),J)=1
INDM(J)=-1
IF(IPR.GE.4)
& WRITE(6,601) J,INDM(J),(ICPTBL(K,J),K=1,NRT)
30 CONTINUE
END IF
1 CONTINUE
RETURN
END
SUBROUTINE INTPOR(JD,II,KBB,ICC,NH,IIR,IUD,IPR)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NAXMAX=20)
PARAMETER (MAXKPT=1000,MAXEIG=16)
PARAMETER (MAXFKP=300,MAXIRP=33)
PARAMETER (N65=129)
CHARACTER*2 MRRM,MRR
COMMON/AXE/EAX(N65,MAXEIG,MAXIRP),NKPT(MAXIRP)
& ,NLIN(MAXIRP),JRR(MAXIRP),JUD(MAXIRP),IRRM(MAXIRP),NAXEN
COMMON/AXP/IFKP(MAXFKP),JSKP(MAXFKP),KKB(3,MAXFKP)
& ,ICCB(MAXFKP),ICPTBL(12,MAXFKP),INDM(MAXFKP),NPOINT
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ix(naxmax),naxm
COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
& ,MRRM(MAXKPT),MRNM(MAXKPT),MWEIM(MAXKPT),NSTM(MAXKPT)
& ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT
C
DIMENSION KBB(3)
DIMENSION XX(N65),YY(N65),X(MAXFKP),YM(MAXEIG,MAXFKP)
DIMENSION SM(MAXFKP),JMAX(MAXFKP)
DIMENSION IXM(MAXFKP),Y(MAXFKP),XXI(MAXFKP)
C
D6=1.0D-6
IF(IPR.GE.2) THEN
KX=KBB(1)
KY=KBB(2)
KZ=KBB(3)
CALL KPNAME(KX,KY,KZ,ICC,MRR,KG)
WRITE(6,600) MRR,IIR
600 FORMAT(' INTERPORATION START FOR ',A2,I2)
END IF
JRR(NAXEN)=II
irrm(NAXEN)=iir
JDOB=JD
WIDE=DBLE(KK2M(IX(II),II))/ICC2M(II)
& -DBLE(KK1M(IX(II),II))/ICC1M(II)
NXI=0
DO 1 I=1,NPOINT
IF(IUD.NE.IUDM(IFKP(I))) GO TO 1
XI=(DBLE(KKB(IX(II),I))/ICCB(I)
& -DBLE(KK1M(IX(II),II))/ICC1M(II))/WIDE
C write(6,*) i,xi,nxi
IF(ICPTBL(IIR,I).EQ.0) GO TO 1
IF(NXI.EQ.0) GO TO 11
DO 15 NI=1,NXI
IF(DABS(XI-X(NI)).LT.1.0D-6) GO TO 12
15 CONTINUE
11 NXI=NXI+1
JMAX(NXI)=0
X(NXI)=XI
NI=NXI
12 IF(INDM(I).EQ.1) THEN
DO 5 L=1,NEIGM(IFKP(I))
DO 2 K=1,ICPTBL(IIR,I)
IF(JMAX(NI).EQ.0) GO TO 51
DO 52 JJ=1,JMAX(NI)
J1=JMAX(NI)-JJ+1
IF(YM(J1,NI).LT.EIGM(L,IFKP(I))) GO TO 53
YM(J1+1,NI)=YM(J1,NI)
52 CONTINUE
51 J1=0
53 YM(J1+1,NI)=EIGM(L,IFKP(I))
JMAX(NI)=JMAX(NI)+1
2 CONTINUE
5 CONTINUE
C write(6,*) ni,jmax(ni),(ym(k,ni),k=1,jmax(ni))
ELSE
DO 54 L=1,NEIGM(IFKP(I))
YM(L,NI)=EIGM(L,IFKP(I))
54 CONTINUE
JMAX(NI)=NEIGM(IFKP(I))
C write(6,*) ni,jmax(ni),(ym(k,ni),k=1,jmax(ni))
END IF
1 CONTINUE
DO 6 I=1,NXI
IXM(I)=I
6 CONTINUE
XXI(1)=X(1)
DO 61 I=2,NXI
DO 62 J=1,I-1
JJ=I-J
IF(XXI(JJ).LT.X(I)) GO TO 63
XXI(JJ+1)=XXI(JJ)
IXM(JJ+1)=IXM(JJ)
62 CONTINUE
JJ=0
63 JJ=JJ+1
XXI(JJ)=X(I)
IXM(JJ)=I
61 CONTINUE
C write(6,*) ' xxi',(xxi(i),i=1,nxi)
NLIN(NAXEN)=0
NKPT(NAXEN)=N65
IF(NXI.LT.3) GO TO 73
JJMAX=0
DO 21 I=1,NXI
IF(JMAX(I).GT.JJMAX) JJMAX=JMAX(I)
21 CONTINUE
C write(6,*) 'jjmax=',jjmax
C write(6,*) (jmax(ixm(i)),i=1,nxi)
DO 70 J=1,JJMAX
NNN=0
NCO=0
DO 71 I=1,NXI
IF(JMAX(IXM(I)).LT.J) GO TO 71
NNN=NNN+1
X(NNN)=XXI(I)
IF(XXI(I)+D6.GE.0.0.AND.XXI(I)-D6.LT.1.0D0) NCO=NCO+1
Y(NNN)=YM(J,IXM(I))
71 CONTINUE
IF(NCO.LT.3) GO TO 70
IF(IPR.GE.4) THEN
WRITE(6,*) ' BAND NO=',J
if(j.eq.1) WRITE(6,666) (X(I),I=1,NNN)
WRITE(6,666) (Y(I),I=1,NNN)
666 FORMAT(10F7.4)
END IF
C1=4.0*((Y(2)-Y(1))/(X(2)-X(1)))
AMU1=2.0
CN=4.0*((Y(NNN)-Y(NNN-1))/(X(NNN)-X(NNN-1)))
ALMN=2.0
NLIN(NAXEN)=J
INIT=0
ICO=0
DO 100 I=1,N65
DD=DBLE(I-1)/(N65-1)
IF(DD.LT.X(1)) GO TO 100
IF(DD.GT.X(NNN)) GO TO 101
IF(INIT.EQ.0) INIT=I
ICO=ICO+1
XX(ICO)=DD
100 CONTINUE
101 CONTINUE
CALL S3N(X,Y,SM,XX,YY,NNN,ICO,C1,CN,AMU1,ALMN)
DO 72 I=1,N65
EAX(I,J,NAXEN)=99.0
72 CONTINUE
DO 75 I=1,ICO
EAX(INIT+I-1,J,NAXEN)=YY(I)
75 CONTINUE
70 CONTINUE
73 RETURN
END
SUBROUTINE S3N(X,Y,SM,XX,YY,N,NN,C1,CN,AMU1,ALMN)
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(99),Y(99),SM(199),XX(199),YY(199)
DIMENSION H(399),ALM(399),AMU(399),C(399),P(399),Q(399),U(399)
N1=N-1
DO 110 I=2,N
H(I)=X(I)-X(I-1)
110 CONTINUE
DO 120 I=2,N1
ALM(I)=H(I+1)/(H(I)+H(I+1))
AMU(I)=1.0-ALM(I)
120 CONTINUE
DO 130 I=2,N1
C(I)=3.0*(ALM(I)*(Y(I)-Y(I-1))/H(I)+AMU(I)*(Y(I+1)-Y(I))/H(I+1))
130 CONTINUE
C(1)=C1
C(N)=CN
AMU(1)=AMU1
ALM(N)=ALMN
P(1)=2.0
Q(1)=-AMU(1)/P(1)
U(1)=C(1)/P(1)
DO 140 K=2,N
P(K)=ALM(K)*Q(K-1)+2.0
Q(K)=-AMU(K)/P(K)
U(K)=(C(K)-ALM(K)*U(K-1))/P(K)
140 CONTINUE
SM(N)=U(N)
DO 150 K=1,N1
K1=N1-K+1
SM(K1)=Q(K1)*SM(K1+1)+U(K1)
150 CONTINUE
DO 160 I=1,NN
XXI=XX(I)
DO 170 K=2,N
IF(XXI.GT.X(K)) GO TO 170
J1=K
GO TO 180
170 CONTINUE
180 J=J1-1
SMJ=SM(J)
SMJ1=SM(J1)
YJ=Y(J)
YJ1=Y(J1)
HJ1=H(J1)
XJ1=X(J1)-XXI
XJ=XXI-X(J)
HJ2=HJ1*HJ1
HJ3=HJ2*HJ1
YY(I)=SMJ*XJ1*XJ1*XJ/HJ2-SMJ1*XJ*XJ*XJ1/HJ2+YJ*XJ1*XJ1*(2.0*XJ+
& HJ1)/HJ3+YJ1*XJ*XJ*(2.0*XJ1+HJ1)/HJ3
160 CONTINUE
RETURN
END
subroutine setpln
PARAMETER (NAXMAX=20)
common/spg2/il,ng,ig(48),jv(2,3,48)
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ix(naxmax),naxm
common/plend/kpl(3,7,2),icpl,iedg(6,2),nplane
integer kplfcc(3,7,2)/0,0,0, 2,0,0, 2,1,0, 2,2,0, 0,0,0,
& 999,999,999, 999,999,999,
& 0,0,0, 2,0,0, 2,2,2, 0,2,2, 0,0,0, 1,1,1, 2,2,2/
integer kb1(3),kk1(3),kg(3)
nplane=2
icpl=2
do 11 ip=1,2
do 12 ipoint=1,7
do 13 k=1,3
kpl(k,ipoint,ip)=kplfcc(k,ipoint,ip)
13 continue
12 continue
11 continue
do 21 i=1,2
do 22 j=1,6
iedg(j,i)=999
if(kpl(1,j+1,i).eq.999) go to 22
do 23 k=1,3
kb1(k)=kpl(k,j,i)+kpl(k,j+1,i)
23 continue
do 24 kax=1,naxm
do 25 k=1,3
kk1(k)=kk1m(k,kax)+kk2m(k,kax)
25 continue
ica1=icc1m(kax)*2
icpl2=icpl*2
call equikk(kb1,icpl2,kk1,ica1,kg,ind1)
if(ind1.ne.0) then
iedg(j,i)=kax
go to 22
end if
24 continue
22 continue
21 continue
C write(6,600) kpl
C write(6,601) iedg
600 format(' KPL'/3I5)
601 format(' IEDG'/6I4)
return
end
SUBROUTINE PLENER(idob,iuod)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (N65=129,ND65=(N65-1)*2+1,maxplp=n65*n65)
PARAMETER (NAXMAX=20)
PARAMETER (MAXKPT=1000,MAXEIG=16)
PARAMETER (MAXFKP=300,MAXIRP=33)
CHARACTER*2 MRRM
COMMON/AXE/EAX(N65,MAXEIG,MAXIRP),NKPT(MAXIRP)
& ,NLIN(MAXIRP),JRR(MAXIRP),JUD(MAXIRP),IRRM(MAXIRP),NAXEN
COMMON/KKEND/KK1M(3,NAXMAX),KK2M(3,NAXMAX)
& ,ICC1M(NAXMAX),ICC2M(NAXMAX),ixxm(naxmax),naxm
COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
& ,MRRM(MAXKPT),MRNM(MAXKPT),MWEIM(MAXKPT),NSTM(MAXKPT)
& ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT
common/plend/kpl(3,7,2),icpl,iedg(6,2),nplane
COMMON/PLE/EPL(maxplp,maxeig,4),irpm(4),nplm(4)
DIMENSION KX(3),keg(3),kkeg(3)
character*2 mrr,mrrk
DIMENSION NM(nd65),X(nd65),Y(nd65),SM(nd65)
& ,XX(nd65),YY(nd65),iep(nd65),IIM(ND65),IEN(N65)
integer nd(12),jtr(12),ipa(12),itcr(12),icp(12,12),icp0(12,12)
jjpl=0
do 20 ipl=1,nplane
do 21 k=1,3
kx(k)=kpl(k,1,ipl)+kpl(k,2,ipl)+kpl(k,3,ipl)
21 continue
icplan=icpl*3
kxx=kx(1)
kyy=kx(2)
kzz=kx(3)
call kpname(kxx,kyy,kzz,icplan,mrr)
call tsirep(kx,icplan,idob)
CALL DGTRST(JDO,NR,NH,NSTR,ND,JTR,IPA)
do 22 ir=1,nr
IF(JTR(IR).EQ.0.AND.IPA(IR).LT.IR) GO TO 22
WRITE(6,662) mrr,ir
662 FORMAT(' ENERGIES IN PLANE ',a2,i2)
jjpl=jjpl+1
irpm(jjpl)=ir
nplm(jjpl)=ipl
DO 101 JJ=1,maxeig
DO 101 N=1,maxplp
101 EPL(N,JJ,jjpl)=99.
iir=ir
do 23 ieg=1,6
if(iedg(ieg,ipl).eq.999) go to 23
j=iabs(iedg(ieg,ipl))
do 24 k=1,3
keg(k)=kpl(k,ieg,ipl)+kpl(k,ieg+1,ipl)
kkeg(k)=kk1m(k,j)*icc2m(j)+kk2m(k,j)*icc1m(j)
24 continue
iceg=icpl*2
ickeg=icc1m(j)*icc2m(j)*2
write(6,*) ' ieg=',ieg,' j=',j
call corres(kkeg,ickeg,keg,iceg,idob,itcr,nrr,ind)
if(ind.eq.0) then
write(6,*) kkeg,ickeg,keg,iceg
write(6,*) ' corres is wrong'
stop
end if
write(6,*) (itcr(k),k=1,nrr)
call compat(kx,icplan,nrr,keg,iceg,nrt,idob,icp,ind)
if(ind.ne.0) then
write(6,*) ' kplane',kx,icplan
write(6,*) ' kedge ',keg,iceg
write(6,*) ' compat is wrong'
stop
end if
C write(6,*) ' icp'
C do 88 i=1,nrt
C write(6,*) (icp(i,k),k=1,nrr)
C 88 continue
call cmptrv(kx,icplan,keg,iceg,idob,icp,icp0)
write(6,*) ' icp0'
do 89 i=1,nrt
write(6,*) (icp0(i,k),k=1,nrr)
89 continue
DO 2 I=1,n65
if(ipl.eq.1) then
IF(ieg.EQ.1) THEN
N=(I*(I-1))/2+1
ELSE IF(ieg.EQ.2) THEN
IF(MOD(I,2).EQ.0) go to 2
II=I/2+1
N=(n65*(n65-1))/2+II
ELSE IF(ieg.EQ.3) THEN
IF(MOD(i,2).eq.0) GO TO 2
II=I/2+1
N=(n65*(n65-1))/2+N65-II+1
ELSE IF(ieg.EQ.4) THEN
N=(I*(I+1))/2
END IF
else if(ipl.eq.2) then
IF(ieg.EQ.1) N=N65*(i-1)+1
IF(ieg.EQ.2) N=n65*(n65-1)+n65-I+1
IF(ieg.EQ.3) N=n65*(n65-I+1)
IF(ieg.EQ.4) N=i
IF(ieg.EQ.5) THEN
IF(MOD(I,2).EQ.0) GO TO 2
II=i/2+1
N=n65*(II-1)+II
END IF
IF(IEG.eq.6) THEN
IF(MOD(I,2).EQ.0) GO TO 2
II=N65-I/2
N=N65*(II-1)+II
END IF
end if
JMAX=0
C write(6,*) ' i=',i,' n=',n
DO 3 K=1,nrt
C write(6,*) k,' icp0=',icp0(iir,itcr(k))
IF(icp0(itcr(k),iir).EQ.0) GO TO 3
DO 1 KKk=1,naxen
C write(6,*) kkk,' jrr=',jrr(kkk),' irrm=',irrm(kkk)
if(jrr(kkk).ne.j) go to 1
if(irrm(kkk).ne.k) go to 1
ii=jjpl
C write(6,*) ' kkk=',kkk,' nlin=',nlin(kkk)
do 5 kk=1,nlin(kkk)
IF(JMAX.EQ.0) GO TO 6
DO 7 JJ=1,JMAX
JJJ=JMAX-JJ+1
IF(EPL(N,JJJ,II).LT.EAX(I,KK,kkk)) GO TO 8
IF(JJJ+1.LE.maxeig) EPL(N,JJJ+1,II)=EPL(N,JJJ,II)
7 CONTINUE
6 JJJ=0
8 IF(JJJ+1.LE.maxeig) EPL(N,JJJ+1,II)=EAX(I,KK,kkk)
IF(JMAX+1.LE.maxeig) JMAX=JMAX+1
5 CONTINUE
1 CONTINUE
3 CONTINUE
C WRITE(6,600) (EPL(N,JJ,II),JJ=1,JMAX)
2 CONTINUE
23 continue
C stop
do 25 k=1,nkpint
if(mrnm(k).ne.iir) go to 25
if(iuod.ne.iudm(k)) go to 25
if(mod((n65-1)*2,icm(k)).ne.0) go to 25
kxx=kxm(1,k)
kyy=kxm(2,k)
kzz=kxm(3,k)
icccc=icm(k)
call kpname(kxx,kyy,kzz,icccc,mrrk)
C write(6,6000) kxx,kyy,kzz,iccc,mrrk
C 6000 format(4i3,2x,a2)
if(ipl.eq.1.and.(mrrk.ne.'ZP'.AND.mrrk.ne.'ZB')) go to 25
if(ipl.eq.2.and.mrrk.ne.'XY') go to 25
if(ipl.eq.1) then
ix=kxm(1,k)*(n65-1)/icm(k)+1
iy=kxm(2,k)*(n65-1)/icm(k)+1
if(mrrk.eq.'ZB') then
ix=(icm(k)-kxm(3,k))*(n65-1)/icm(k)+1
iy=(icm(k)-kxm(2,k))*(n65-1)/icm(k)+1
end if
n=(ix*(ix-1))/2+iy
else if(ipl.eq.2) then
if(kxm(1,k).eq.kxm(2,k)) then
ix=kxm(3,k)*(n65-1)/icm(k)+1
iy=kxm(1,k)*(n65-1)/icm(k)+1
else if(kxm(2,k).eq.kxm(3,k)) then
ix=kxm(1,k)*(n65-1)/icm(k)+1
iy=kxm(2,k)*(n65-1)/icm(k)+1
end if
n=n65*(ix-1)+iy
ixx=N65-Ix+1
iyy=N65-iy+1
nnn=n65*(ixx-1)+iyy
end if
DO 42 KK=1,NEIGM(k)
EPL(N,KK,II)=EIGM(KK,k)
IF(IPL.EQ.2) EPL(NNN,KK,II)=EIGM(KK,k)
42 CONTINUE
write(6,602) ii,k,ix,iy,n
if(ipl.eq.2) write(6,602) ii,k,ixx,iyy,nnn
write(6,600) (epl(n,kk,ii),kk=1,neigm(k))
25 continue
22 CONTINUE
20 continue
C
C INTERPOLATION IN PLAN
C
DO 210 III=1,4
DO 200 JJ=1,MAXEIG
IF(EPL(1,JJ,III).GT.8.9) GO TO 200
DO 201 I=1,5
nxy=1
if(iii.ge.3.and.i.ne.5) nxy=2
do 251 ixy=1,nxy
NN=7
if(i.eq.2) nn=8
IF(I.ge.3) NN=8*(2**(I-2))
DO 202 J=1,NN
IF(I.EQ.1) IX=J*16+1
IF(I.EQ.2) IX=J*16-7
IF(I.EQ.3) IX=J*8-3
IF(I.EQ.4) IX=J*4-1
IF(I.EQ.5) IX=J*2
MM=0
KNUM=N65
C write(6,602) III,I,IXY,IX,KNUM
DO 203 K=1,KNUM
IIM(K)=III
KK=K
IIX=IX
JX=IIX
JY=KK
if((III.LE.2.and.JX.lt.JY).or.ixy.eq.2) then
JX=KK
JY=IIX
end if
if(III.LE.2) NM(K)=(JX*(JX-1))/2+JY
if(III.GE.3) nm(k)=n65*(jx-1)+jy
XX(K)=K-1
IF(EPL(NM(K),JJ,IIM(K)).GT.90.0) GO TO 203
MM=MM+1
X(MM)=K-1
Y(MM)=EPL(NM(K),JJ,IIM(K))
203 CONTINUE
IF(MM.LT.3) GO TO 202
C write(6,602) III,I,IXY,IX,MM
C write(6,600) (X(K),K=1,MM)
C write(6,600) (Y(k),k=1,mm)
600 FORMAT(8F8.4)
602 FORMAT(8I8)
CALL S3N(X,Y,SM,XX,YY,MM,KNUM,0.0d0,0.0d0,0.0d0,0.0d0)
C write(6,600) (YY(k),k=1,knum)
DO 204 K=1,KNUM
204 EPL(NM(K),JJ,IIM(K))=YY(K)
202 CONTINUE
251 continue
201 CONTINUE
IF(III.EQ.1.OR.III.EQ.2) THEN
WRITE(6,663) III,JJ
663 FORMAT(' ENERGIES IN Z-PLANE',2I5)
ELSE
WRITE(6,664) III,JJ
664 FORMAT(' ENERGIES IN XY-PLANE',2I5)
ENDIF
DO 135 I=1,n65,2
IF(III.LE.2) JEND=I
IF(III.GE.3) JEND=n65
DO 136 J=1,JEND
IF(III.EQ.1.OR.III.EQ.2) N=(I*(I-1))/2+J
IF(III.GE.3) N=N65*(I-1)+J
IEN(J)=INT(EPL(N,JJ,III)*10000+0.5)
136 CONTINUE
WRITE(6,603) (IEN(J),J=1,JEND,2)
603 FORMAT(30I5)
135 CONTINUE
200 CONTINUE
210 continue
RETURN
END