************************************************************************ Program Renorm_4 Common Is(0:7,0:7),Ib(3,3),Nsweeps,Iran Call Initialize Nsweeps=100000 Xmin=0.437 Xmax=0.438 NumberOfRuns=6 NumberOfIters=7 DelX=(Xmax-Xmin)/(NumberOfRuns-1) Do 2 Xstart=Xmin, Xmax, DelX X1=Xstart X2=0 X3=0 Write(1,100)X1,X2,X3 Do 1 I = 1, NumberOfIters Call FindCorrFtns(X1,X2,X3,C1,C2,C3) Call FindHamPars(C1,C2,C3,X1,X2,X3) 1 Write(1,100)X1,X2,X3 2 Write(1,*) Close(1) 100 Format(3F12.6) End ************************************************************************ Subroutine FindCorrFtns(X1,X2,X3,C1,C2,C3) Common Is(0:7,0:7),Ib(3,3),Nsweeps,Iran Do 1 n=1,1000 1 Call Sweep(X1,X2,X3) Sum1=0 Sum2=0 Sum3=0 Do 2 n=1,Nsweeps Call Sweep(X1,X2,X3) Call MakeBlockSpins Sum1=Sum1+ #Ib(1,1)*Ib(1,2)+Ib(1,2)*Ib(1,3)+Ib(2,1)*Ib(2,2)+Ib(2,2)*Ib(2,3)+ #Ib(3,1)*Ib(3,2)+Ib(3,2)*Ib(3,3)+Ib(1,1)*Ib(2,1)+Ib(2,1)*Ib(3,1)+ #Ib(1,2)*Ib(2,2)+Ib(2,2)*Ib(3,2)+Ib(1,3)*Ib(2,3)+Ib(2,3)*Ib(3,3) Sum2=Sum2+ #Ib(1,1)*Ib(2,2)+Ib(1,2)*Ib(2,1)+Ib(1,2)*Ib(2,3)+Ib(1,3)*Ib(2,2)+ #Ib(2,1)*Ib(3,2)+Ib(2,2)*Ib(3,1)+Ib(2,2)*Ib(3,3)+Ib(2,3)*Ib(3,2) Sum3=Sum3+ #Ib(1,1)*Ib(1,2)*Ib(2,2)*Ib(2,1)+Ib(1,2)*Ib(1,3)*Ib(2,3)*Ib(2,2)+ #Ib(2,1)*Ib(2,2)*Ib(3,2)*Ib(3,1)+Ib(2,2)*Ib(2,3)*Ib(3,3)*Ib(3,2) 2 Continue C1=Sum1/Nsweeps C2=Sum2/Nsweeps C3=Sum3/Nsweeps Return End ************************************************************************ Subroutine MakeBlockSpins Common Is(0:7,0:7),Ib(3,3),Nsweeps,Iran Ib(1,1)=Iblock(Is(1,1)+Is(1,2)+Is(2,1)+Is(2,2)) Ib(1,2)=Iblock(Is(1,3)+Is(1,4)+Is(2,3)+Is(2,4)) Ib(1,3)=Iblock(Is(1,5)+Is(1,6)+Is(2,5)+Is(2,6)) Ib(2,1)=Iblock(Is(3,1)+Is(3,2)+Is(4,1)+Is(4,2)) Ib(2,2)=Iblock(Is(3,3)+Is(3,4)+Is(4,3)+Is(4,4)) Ib(2,3)=Iblock(Is(3,5)+Is(3,6)+Is(4,5)+Is(4,6)) Ib(3,1)=Iblock(Is(5,1)+Is(5,2)+Is(6,1)+Is(6,2)) Ib(3,2)=Iblock(Is(5,3)+Is(5,4)+Is(6,3)+Is(6,4)) Ib(3,3)=Iblock(Is(5,5)+Is(5,6)+Is(6,5)+Is(6,6)) Return End ************************************************************************ Function Iblock(K) Common Is(0:7,0:7),Ib(3,3),Nsweeps,Iran If(K.NE.0)then Iblock=K/Iabs(K) Return End If If(Ran(Iran).GT.0.5)then Iblock=1 Else Iblock=-1 End If Return End ************************************************************************ Subroutine Sweep(X1,X2,X3) Common Is(0:7,0:7),Ib(3,3),Nsweeps,Iran Do 1 i=1,6 Do 1 j=1,6 DelE=2*Is(i,j)*(X1*(Is(i-1,j)+Is(i,j+1)+Is(i+1,j)+Is(i,j-1))+ #X2*(Is(i-1,j-1)+Is(i-1,j+1)+Is(i+1,j+1)+Is(i+1,j-1))+ #X3*(Is(i,j-1)*Is(i-1,j-1)*Is(i-1,j)+Is(i-1,j)*Is(i-1,j+1)* #Is(i,j+1)+Is(i,j+1)*Is(i+1,j+1)*Is(i+1,j)+Is(i+1,j)* #Is(i+1,j-1)*Is(i,j-1))) If((DelE.LT.0).OR.(Ran(Iran).LT.Exp(-DelE)))Is(i,j)=-Is(i,j) 1 Continue Return End *********************************************************************** Subroutine FindHamPars(C10,C20,C30,X1,X2,X3) Real*4 CoefMat(3,3),DelC(3),DelX(3) Integer*2 A,B,C,D,E,F,G,H,I Data Tolerance /0.00001/ Do 2 Iter=1,100 W1=Exp(X1) W2=Exp(X2) W3=Exp(X3) Z=0 S1=0 S2=0 S3=0 S11=0 S12=0 S13=0 S22=0 S23=0 S33=0 Do 1 A = -1, 1, 2 Do 1 B = -1, 1, 2 Do 1 C = -1, 1, 2 Do 1 D = -1, 1, 2 Do 1 E = -1, 1, 2 Do 1 F = -1, 1, 2 Do 1 G = -1, 1, 2 Do 1 H = -1, 1, 2 Do 1 I = -1, 1, 2 nn=A*B+B*C+D*E+E*F+G*H+H*I+A*D+D*G+B*E+E*H+C*F+F*I nnn=A*E+B*D+B*F+C*E+D*H+E*G+E*I+F*H nsq=A*B*E*D+B*C*F*E+D*E*H*G+E*F*I*H Weight=W1**nn*W2**nnn*W3**nsq S1=S1+Weight*nn S2=S2+Weight*nnn S3=S3+Weight*nsq S11=S11+Weight*nn**2 S12=S12+Weight*nn*nnn S13=S13+Weight*nn*nsq S22=S22+Weight*nnn**2 S23=S23+Weight*nnn*nsq S33=S33+Weight*nsq**2 Z=Z+Weight 1 Continue C1=S1/Z C2=S2/Z C3=S3/Z DelC(1)=C10-C1 DelC(2)=C20-C2 DelC(3)=C30-C3 CoefMat(1,1)=S11/Z-C1**2 CoefMat(1,2)=S12/Z-C1*C2 CoefMat(1,3)=S13/Z-C1*C3 CoefMat(2,1)=CoefMat(1,2) CoefMat(2,2)=S22/Z-C2**2 CoefMat(2,3)=S23/Z-C2*C3 CoefMat(3,1)=CoefMat(1,3) CoefMat(3,2)=CoefMat(2,3) CoefMat(3,3)=S33/Z-C3**2 Call Solve(CoefMat,DelC,DelX) X1=X1+DelX(1) X2=X2+DelX(2) X3=X3+DelX(3) If(Sqrt(DelX(1)**2+DelX(2)**2+DelX(3)**2).LT.Tolerance)GoTo 3 2 Continue 3 Continue Return End *********************************************************************** Subroutine Solve(A,B,X) Real*4 A(3,3),B(3),X(3) Do 2 i=1,3 C=Sqrt(A(i,1)**2+A(i,2)**2+A(i,3)**2) Do 1 j=1,3 1 A(i,j)=A(i,j)/C 2 B(i)=B(i)/C C=A(1,1)*A(2,1)+A(1,2)*A(2,2)+A(1,3)*A(2,3) D=Sqrt(1-C**2) Do 3 i=1,3 3 A(2,i)=(A(2,i)-C*A(1,i))/D B(2)=(B(2)-C*B(1))/D C1=A(1,1)*A(3,1)+A(1,2)*A(3,2)+A(1,3)*A(3,3) C2=A(2,1)*A(3,1)+A(2,2)*A(3,2)+A(2,3)*A(3,3) D=Sqrt(1-C1**2-C2**2) Do 4 i=1,3 4 A(3,i)=(A(3,i)-C1*A(1,i)-C2*A(2,i))/D B(3)=(B(3)-C1*B(1)-C2*B(2))/D Do 5 i=1,3 5 X(i)=B(1)*A(1,i)+B(2)*A(2,i)+B(3)*A(3,i) Return End ************************************************************************ Subroutine Initialize Common Is(0:7,0:7),Ib(3,3),Nsweeps,Iran Iran=99991 Open(Unit=1,File='Renorm_4.out') Write(1,*)' X1 X2 X3' Write(1,*) Do 1 i=1,6 Do 1 j=1,6 If(Ran(Iran).LT.0.5)then Is(i,j)=1 Else Is(i,j)=-1 End If 1 Continue Do 2 i=0,7 Is(0,i)=0 Is(7,i)=0 Is(i,0)=0 2 Is(i,7)=0 End ************************************************************************