[Fortran] 纯文本查看 复制代码
SUBROUTINE BMATCH (SM,LAM,A1,A3,S,T,E,V,W,NN,LR,FLOAD,FAMP)
IMPLICIT REAL*8 (A-H,O-Z)
COMPLEX*16 SM(1),LAM(1),A1(1),A3(1),S(1),T(1),E(NN)
COMPLEX*16 V(NN,NN),W(NN,NN),C,CC,D,DD
COMPLEX*16 FLOAD(1),FAMP(1)
COMMON /LRCHK/ NCOMF
N1=NN-1
N2=NN-2
N3=NN-3
F=.5D0
DO 30 J=1,NN
C=E(J)*(0.0D0,1.0D0)
DO 30 I=1,NN
30 W(I,J)=V(I,J)*C
DO 60 J=1,NN
S(1)=A1(1)*W(1,J)+A3(1)*W(3,J)
S(2)=A1(2)*W(2,J)+A3(2)*W(4,J)
S(N1)=A1(N1)*W(N1,J)+A3(N3)*W(N3,J)
S(NN)=A1(NN)*W(NN,J)+A3(N2)*W(N2,J)
DO 50 I=3,N2
50 S(I)=A3(I-2)*W(I-2,J)+A1(I)*W(I,J)+A3(I)*W(I+2,J)
DO 60 I=1,NN
60 W(I,J)=S(I)
CALL INVERT (V,NN,NN,S,T,DET) 错误定位在这一行，说S的类型不对。
DO 80 I=1,NN
DO 70 J=I,NN
S(J)=(0.0D0,0.0D0)
DO 70 K=1,NN
70 S(J)=S(J)+W(I,K)*V(K,J)
DO 80 J=I,NN
80 W(I,J)=S(J)
CC=(0.0D0,0.0D0)
DD=(0.0D0,0.0D0)
M=0
DO 100 I=2,N2,2
K=I-1
M=M+1
C=F*LAM(M)
D=F*SM(M)
W(K,I)=W(K,I)+C-CC
W(K,K+3)=W(K,K+3)-C
W(I,I+1)=W(I,I+1)-D
CC=C
100 DD=D
W(N1,NN)=W(N1,NN)-CC+F*LAM(M+1)
DO 105 I=1,NN
DO 105 J=I,NN
105 W(J,I)=W(I,J)
L=0
DO 150 J=1,NN
DO 150 I=1,J
L=L+1
V(L,1)=W(I,J)
150 W(L,1)=V(L,1)
M=0
K=-2
DO 200 I=1,NN,2
K=K+4
L=M+1
M=L+K
N=L+1
DO 180 J=N,M,2
IF (NCOMF.EQ.0) GO TO 181
W(J,1)=-W(J,1)
GO TO 180
181 CONTINUE
V(J,1)=-V(J,1)
180 CONTINUE
200 CONTINUE
READ (24) (FAMP(LK),LK=1,NN)
IF (LR-2) 300,400,300
300 WRITE (23) M, (W(J,1),J=1,M)
CALL FVECT(NN,FLOAD,W,FAMP)
IF (LR .EQ. 3) GO TO 400
RETURN
400 WRITE (23) M, (V(J,1),J=1,M)
CALL FVECT(NN,FLOAD,V,FAMP)
RETURN
END
[Fortran] 纯文本查看 复制代码
SUBROUTINE INVERT (A,NN,N,M,C,DET)
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION M(1)
COMPLEX*16 A(N,1),C(1),D,TEMP,DE
DE=(1.0D0,0.0D0)
IF (NN-1) 300,350,100
100 DO 110 I = 1,NN
110 M(I) = -I
DO 200 I = 1,NN
X=0.0D0
DO 130 L = 1,NN
IF (M(L).GT.0) GO TO 130
DO 120 K = 1,NN
IF (M(K).GT.0) GO TO 120
D=A(L,K)
Y=DABS(DREAL(D))+DABS(DIMAG(D))
IF (X.GT.Y) GO TO 120
LD = L
KD = K
X=Y
120 CONTINUE
130 CONTINUE
D=A(LD,KD)
DE=DE*D
L = -M(LD)
M(LD) = M(KD)
M(KD) = L
DO 140 J = 1,NN
C(J) = A(LD,J)
A(LD,J) = A(KD,J)
140 A(KD,J) = C(J)
DO 150 K = 1,NN
150 A(K,KD) = A(K,KD)/D
DO 170 J = 1,NN
IF (J.EQ.KD) GO TO 170
DO 160 K = 1,NN
160 A(K,J) = A(K,J) - C(J)*A(K,KD)
170 CONTINUE
C(KD) =(-1.0D0,0.0D0)
DO 180 K = 1,NN
180 A(KD,K) = -C(K)/D
200 CONTINUE
DO 240 I = 1,NN
L = 0
220 L = L + 1
IF (M(L).NE.I) GO TO 220
M(L) = M(I)
M(I) = I
DO 240 K = 1,NN
TEMP = A(K,L)
A(K,L) = A(K,I)
240 A(K,I) = TEMP
DET=CDABS(DE)
300 RETURN
350 A(1,1) = 1.0D0/A(1,1)
DET=CDABS(A(1,1))
GO TO 300
END