IMPLICIT REAL*8 (A-H,O-Z)
EXTERNAL FUNC
C EXTERNAL TLINT,BZIORO,LBZIO,TPDUMY
COMMON/BZPL/KG(3,20),NG,IEOH,INDC,IBR,ICUT
DIMENSION NRECPT(3,30),RECTAX(4,30)
C
C SUBROUTINE IN TPERSP USE REAL*4
C
REAL*8 XFU(3,2),WF(3),EF,EE
REAL*8 EM,PN,p
REAL*8 XX(3),XC(3),DR(3)
real*8 func
common/enrspl/EM(366145),PN(3),p(3),n(3),js
INTEGER M(3),NN(3),NK(3)
READ(21,*) NB,IEOH
DO 10 J=1,NB
READ(31) IXMAX,NB,NNEE
READ(31) (EM(K),K=1,NNEE)
WRITE(6,*) IXMAX,NB,NNEE
10 CONTINUE
PN(1)=1.0
PN(2)=1.0
PN(3)=1.0
n(1)=IXMAX-1
n(2)=n(1)
n(3)=n(1)
js=3
DO 51 I=1,3
P(I)=Pn(I)/FLOAT(N(I))
51 CONTINUE
XX(1)=0.5
XX(2)=0.5
XX(3)=0.5
WWWW=FUNC(XX)
WRITE(6,*) WWWW
READ(21,*) (XFU(I,1),I=1,3)
READ(21,*) (XFU(I,2),I=1,3)
READ(21,*) SIZE
WF(1)=SIZE
WF(2)=WF(1)
WF(3)=WF(1)
C
READ(21,*) (XC(I),I=1,3)
READ(21,*) (DR(I),I=1,3)
READ(21,*) EF,DDE,NDE
write(6,*) EF,DDE,NDE
READ(21,*) N241,NK2
write(6,*) XC,DR,EF
write(6,*) N241,NK2
READ(21,*) IFL
CALL AYPSTR(IFL)
CALL AYORIG(30.0,30.0)
CALL TPCSEC(XFU,WF)
CALL TPTRAC(1)
C IEOH=1
CALL TPSCHG(IEOH)
CALL LINEWD(2.0)
NNX=N241
NNY=N241
KKX=NK2
KKY=NK2
CALL TPSECT(FUNC,EF,DR,XC,0,1,NNX,NNY,KKX,KKY)
CALL LINEWD(1.0)
DO 31 IE=1,NDE
EE=EF+IE*DDE
CALL TPSECT(FUNC,EE,DR,XC,1,0,NNX,NNY,KKX,KKY)
EE=EF-IE*DDE
CALL TPSECT(FUNC,EE,DR,XC,1,0,NNX,NNY,KKX,KKY)
31 CONTINUE
CALL AYPEND
STOP
END
C FUNCTION TLINTP(XX,JS)
C *** THREE DIMENSIONAL INTERPOLATION BY A LINEAR FORMULA
C *** PERIODICITY AND F(X,Y,Z)=F(ABS(X),ABS(Y),ABS(Z))
C *** ARE ASSUMED.
C *** IS=1 ORTHORHOMBIC SYMMETRY
C *** IS=2 TETRAGONAL SYMMETRY
C *** IS=3 CUBIC SYMMETRY
FUNCTION FUNC(XX)
IMPLICIT REAL*8 (A-H,O-Z)
REAL*8 KB
C DIMENSION EM(NN),PM(3),N(3),XX(3),M(3),PN(3)
common/enrspl/em(366145),pm(3),p(3),n(3),is
DIMENSION IFAC(3)
DIMENSION A(4),IPER(3,6),FF(2,2,2),F(8),KB(3)
EQUIVALENCE(F(1),FF(1,1,1))
DATA IPER/1,2,3, 1,3,2, 3,1,2, 2,1,3, 2,3,1, 3,2,1/
DATA IFAC/1,2,4/
data niold,ipold/0,0/
save niold,ipold
REAL*8 xx(3)
C DO 53 I=1,3
C PM(I)=PN(I)
C N(I)=M(I)
C 53 CONTINUE
C
C *** KB IN THE FIRST ZONE ***
C write(6,*) xx,ipold,niold
DO 1 I=1,3
KB(I)=XX(I)
2 KB(I)=ABS(KB(I))
IF(KB(I).LE.PM(I)) GO TO 1
KB(I)=KB(I)-PM(I)*2.0
GO TO 2
1 CONTINUE
IF(IS.EQ.1) GO TO 4
C *** KB(1).GE.KB(2).GE.KB(3) ***
IF(KB(1).GE.KB(2)) GO TO 3
W=KB(1)
KB(1)=KB(2)
KB(2)=W
3 CONTINUE
IF(IS.EQ.2) GO TO 4
IF(KB(2).GE.KB(3)) GO TO 4
W=KB(2)
KB(2)=KB(3)
KB(3)=W
IF(KB(1).GE.KB(2)) GO TO 4
W=KB(1)
KB(1)=KB(2)
KB(2)=W
C *** FIND THE BLOCK WHERE THE POINT IS ***
4 IX=KB(1)/P(1)
IF(IX.EQ.N(1)) IX=N(1)-1
IY=KB(2)/P(2)
IF(IY.EQ.N(2)) IY=N(2)-1
IZ=KB(3)/P(3)
IF(IZ.EQ.N(3)) IZ=N(3)-1
IF(IS.EQ.1) NI=(IX*(N(2)+1)+IY)*(N(3)+1)+IZ+1
IF(IS.EQ.2) NI=((IX*(IX+1))/2+IY)*(N(3)+1)+IZ+1
IF(IS.EQ.3) NI=(IX*(IX+1)*(IX+2))/6
1 +(IY*(IY+1))/2+IZ+1
C *** IF THE BLOCK IS THE SAME, GO TO 40 ***
IF(NI.EQ.NIOLD) GO TO 40
C *** PICK UP THE ENERGIES OF 8 POINTS ***
NK=NI
IF(IS.EQ.1) MX=(N(2)+1)*(N(3)+1)
IF(IS.EQ.2) MX=(IX+1)*(N(3)+1)
IF(IS.EQ.3) MX=((IX+1)*(IX+2))/2
DO 41 KX=1,2
DO 42 KY=1,2
DO 43 KZ=1,2
FF(KX,KY,KZ)=EM(NK)
NK=NK+1
43 CONTINUE
IF(IS.NE.3) NK=NK-2+(N(3)+1)
IF(IS.EQ.3) NK=NK-2+IY+KY
42 CONTINUE
IF(KX.LT.2) NK=NI+MX
41 CONTINUE
40 CONTINUE
C *** FIND THE TETRAHEDRON ***
X=KB(1)-P(1)*DFLOAT(IX)
Y=KB(2)-P(2)*DFLOAT(IY)
Z=KB(3)-P(3)*DFLOAT(IZ)
IF(X.GE.Y) GO TO 11
IF(Y.GE.Z) GO TO 12
IP=6
GO TO 13
12 IF(X.GE.Z) GO TO 24
IP=5
GO TO 13
24 IP=4
GO TO 13
11 IF(Y.GE.Z) GO TO 21
IF(X.GE.Z) GO TO 22
IP=3
GO TO 13
22 IP=2
GO TO 13
21 IP=1
C *** IF THE TETRAHEDRON IS THE SAME, GO TO 10 ***
13 IF(NIOLD.NE.NI) GO TO 14
IF(IPOLD.EQ.IP) GO TO 10
14 IPOLD=IP
NIOLD=NI
C *** DETERMINE THE COEFFICIENTS OF LINEAR FORM ***
K1=IPER(1,IP)
K2=IPER(2,IP)
K3=IPER(3,IP)
I1=IFAC(K1)
I2=IFAC(K2)
I3=IFAC(K3)
A(4)=F(1)
JA=I1+1
A(K1)=(F(JA)-F(1))/P(K1)
JB=I1+I2+1
A(K2)=(F(JB)-F(JA))/P(K2)
A(K3)=(F(8)-F(JB))/P(K3)
10 WWW=X*A(1)+Y*A(2)+Z*A(3)+A(4)
FUNC=WWW
C IF((ABS(ABS(XX(1))-0.5).LE.0.02).AND.
C & (ABS(ABS(XX(2))-0.5).LE.0.02).AND.
C & (ABS(ABS(XX(3))-0.5).LE.0.02)) write(6,600) xx,www
C 600 format(4f10.5)
RETURN
END
C FUNCTION BZIORO ====*====3====*====4====*====5====*====6====*====7
C
C HIDDEN LINE FUNCTION FOR B.Z.PLOT
C
C 1988.10.18 : A. YANASE
C
C---*----1----*----2----*----3----*----4----*----5----*----6----*----7
C FUNCTION BZIORO(XA)
C FUNCTION FUNCD(XA)
C DIMENSION XA(3)
C FUNCD=1.0
C RETURN
C END
C FUNCTION LFUNC(XA)
C DIMENSION XA(3)
C LFUNC=-1
C RETURN
C 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