[Fortran] 纯文本查看 复制代码
C This programme is used to correlate the Antoine constants C
C for vapor pressure of pure components C
C C
C The Antoine equation of vapor pressure is C
C C
C lg(p)=AntA-AntB/(t+AntC) C
C where C
C p in kPa and t in C
PROGRAM LIU53
CHARACTER DATFILE*12,RESFILE*12,SYSNAME*30,SYSFORM*10
DIMENSION A(7,7),B(7),X(7),PC(60),DP(60)
COMMON /TP/ TE(60),PE(60)
WRITE(*,'(1X////1X)')
WRITE(*,*) 'Input the file name of data file'
READ(*,'(A12)') DATFILE
OPEN(4,FILE=DatFile,STATUS='OLD')
READ(4,*) SYSNAME,SYSFORM
READ(4,*) ND,IPUNIT,ITUNIT
C
C ITUNIT indicating the unit of temperature
C =0 for K =1 for C
C
C IPUNIT indicating the unit of pressure
C =0 for kPa
C =1 for mmHg
C =2 for atm
C =3 for bar
C =4 for MPa
C
READ(4,*) (TE(I),PE(I),I=1,ND)
CLOSE(4)
TMIN=TE(1)
TMAX=TE(ND)
DO 10 I=1,ND
IF (ITUNIT.EQ.0) TE(I)=TE(I)-273.15
IF (IPUNIT.EQ.1) PE(I)=PE(I)/760.*101.325
IF (IPUNIT.EQ.2) PE(I)=PE(I)*101.325
IF (IPUNIT.EQ.3) PE(I)=PE(I)*100.0
IF (IPUNIT.EQ.4) PE(I)=PE(I)*1000.0
10 CONTINUE
DO 180 I=1,7
DO 190 J=1,7
A(I,J)=0.0
190 CONTINUE
B(I)=0.0
180 CONTINUE
DO 200 I=1,ND
PLG=ALOG(PE(I))/2.302585
T=TE(I)
B(1)=B(1)+T*T*PLG
B(2)=B(2)+T*PLG*PLG
B(3)=B(3)+T*PLG
A(1,1)=A(1,1)+T*T
A(1,3)=A(1,3)+T
A(2,2)=A(2,2)+PLG*PLG
A(2,3)=A(2,3)+PLG
200 CONTINUE
A(1,2)=B(3)
A(2,1)=A(1,2)
A(3,1)=A(1,3)
A(3,2)=A(2,3)
A(3,3)=FLOAT(ND)
N=3
CALL INVB(N,A)
DO 210 I=1,N
X(I)=0.0
DO 220 J=1,N
X(I)=X(I)+A(I,J)*B(J)
220 CONTINUE
210 CONTINUE
ANTA=X(1)
ANTC=-X(2)
ANTB=ANTA*ANTC-X(3)
N=3
X(1)=ANTA
X(2)=ANTB
X(3)=ANTC
M=ND
CALL SM(N,M,X)
ANTA=X(1)
ANTB=X(2)
ANTC=X(3)
RDP=0.0
DO 230 I=1,ND
PC(I)=EXP((ANTA-ANTB/(TE(I)+ANTC))*2.302585)
DP(I)=PE(I)-PC(I)
RDP=RDP+ABS(DP(I))/PE(I)
230 CONTINUE
RDP=RDP*100.0/FLOAT(ND)
WRITE(*,'(1X////1X)')
WRITE(*,*) 'Input the file name of result file'
READ(*,'(A12)') RESFILE
OPEN(4,FILE=ResFile,STATUS='NEW')
WRITE(4,240)
240 FORMAT(5X,'Correlation of vapor pressure for component')
WRITE(4,250) SYSNAME,SYSFORM
250 FORMAT(/5X,A30,3X,A10)
WRITE(4,260) ANTA,ANTB,ANTC,TMIN,TMAX
260 FORMAT(/5X,'ANTA=',F7.5,2X,'ANTB=',F9.3,2X,'ANTC=',F7.3,
1 2X,'TMIN=',F6.2,2X,'TMAX=',F6.2)
WRITE(4,270)
270 FORMAT(/7X,'T/K',5X,'Pe/kPa',3X,'Pc/kPa',2X,'DP/kPa')
WRITE(4,280) (I,TE(I),PE(I),PC(I),DP(I),I=1,ND)
280 FORMAT(2X,I2,2X,F6.2,2X,F7.3,2X,F7.3,2X,F6.3)
WRITE(4,290) RDP
290 FORMAT(/5X,'RDP=',F6.2,'%')
CLOSE(4)
STOP
END
SUBROUTINE VFRE(X,N,M,Y)
DIMENSION X(5),Y(60)
COMMON /TP/ TE(60),PE(60)
ANTA=X(1)
ANTB=X(2)
ANTC=X(3)
DO 10 I=1,M
PC=EXP((ANTA-ANTB/(TE(I)+ANTC))*2.302585)
Y(I)=1.0-PC/PE(I)
10 CONTINUE
RETURN
END
C***********************************************************************C
C C
C SUBROUTINE INVB(N,A) C
C C
C PURPOSE C
C C
C calculate the inverse matrix of matrix A C
C C
C A ( N , N ) C
C C
C The result is also put in A(N,N) C
C C
C C
C***********************************************************************C
C
SUBROUTINE INVB(N,A)
C
DIMENSION A(7,7)
IF (N-2) 11,11,22
11 AI=A(1,1)*A(2,2)-A(1,2)*A(2,1)
AI=1.0/AI
AJ=A(1,1)
A(1,1)=A(2,2)*AI
A(2,2)=AI*AJ
A(2,1)=-A(2,1)*AI
A(1,2)=-A(1,2)*AI
RETURN
22 DO 20 K=1,N
P=1.0/A(K,K)
A(K,K)=P
DO 30 I=1,N
IF (I.NE.K) A(I,K)=-P*A(I,K)
30 CONTINUE
DO 40 I=1,N
IF (I.EQ.K) GOTO 60
DO 50 J=1,N
IF (J.NE.K) A(I,J)=A(I,J)+A(I,K)*A(K,J)
50 CONTINUE
60 CONTINUE
40 CONTINUE
DO 70 J=1,N
IF (J.NE.K) A(K,J)=P*A(K,J)
70 CONTINUE
20 CONTINUE
RETURN
END
C***********************************************************************C
C C
C SUBROUTINE SM(N,M,X) C
C C
C PURPOSE C
C C
C calculating the optimum parameter values C
C C
C C
C N : the number of the paramrters required estimation C
C M : the number of the equation C
C X(N) : the parameters required estimation C
C put the start value at the first C
C put the optimum values in the last C
C SIGAMY : external function procedure for calculating the C
C objective function value C
C C
C***********************************************************************C
C
SUBROUTINE SM(N,M,X)
C
INTEGER T,A2,B2,C2,N,M,K,TT
DIMENSION X(5),R1(5),R2(5),R3(5),Q(6),P(6,5)
V=.01
MAXP=220
TT=0
AN=N
10 DO 20 T=1,N+1
DO 30 K=1,N
IF ((T-1).NE.K) THEN
R1(K)=X(K)
P(T,K)=X(K)
ELSE IF (ABS(X(K)).LT.1.E-6) THEN
R1(K)=1.E-6
P(T,K)=1.E-6
ELSE
R1(K)=(1.0+V)*X(K)
P(T,K)=(1.0+V)*X(K)
ENDIF
30 CONTINUE
Q(T)=SIGAMY(N,M,R1)
20 CONTINUE
40 A1=0.
B1=0.
C1=1.E18
DO 50 T=1,N+1
IF (A1.GT.Q(T)) GO TO 60
A1=Q(T)
A2=T
60 IF (C1.LT.Q(T)) GO TO 50
C1=Q(T)
C2=T
50 CONTINUE
DO 70 T=1,N+1
IF (T.NE.A2.AND.B1.LT.Q(T)) THEN
B1=Q(T)
B2=T
ENDIF
70 CONTINUE
DO 80 K=1,N
X(K)=P(C2,K)
80 R1(K)=0.
TT=TT+1
SMN=0.
DO 85 K=1,N+1
85 SMN=SMN+Q(K)/(AN+1.)
SD=0.
ANTA=0.
DO 87 K=1,N+1
SD=SD+(Q(K)/SMN-1.)**2
87 ANTA=ANTA+(Q(K)-SMN)**2
ANTA=SQRT(ANTA/(AN+1.))
SD=SQRT(SD/(AN+1.0))
C WRITE(*,88)ANTA,SD,TT
IF (SD.LE.1.E-7.OR.ANTA.LE.1.E-7) GO TO 170
IF (TT.GE.MAXP.OR.V.LT.0.0001) GO TO 170
88 FORMAT(1X,5HANTA=,E10.2,2X,3HSD=,E10.2,2X,3HTT=,I3)
IF (C1.LE.1.E-7.OR.ABS(1.-A1/C1).LE.1.E-7) GO TO 170
DO 100 T=1,N+1
DO 90 K=1,N
IF (T.NE.A2) R1(K)=R1(K)+P(T,K)/AN
90 CONTINUE
100 CONTINUE
DO 110 K=1,N
110 R2(K)=2.*R1(K)-P(A2,K)
S=SIGAMY(N,M,R2)
IF (S.GE.A1) GO TO 150
DO 120 K=1,N
R3(K)=3.*R1(K)-2.*P(A2,K)
120 P(A2,K)=R2(K)
Q(A2)=S
U=SIGAMY(N,M,R3)
IF (U.GE.S) GO TO 40
130 DO 140 K=1,N
140 P(A2,K)=R3(K)
Q(A2)=U
GO TO 40
150 DO 160 K=1,N
160 R3(K)=R1(K)/2.+P(A2,K)/2.
U=SIGAMY(N,M,R3)
IF (U.LT.B1) GO TO 130
V=V/2.0
GOTO 10
170 CONTINUE
RETURN
END
FUNCTION SIGAMY(N,M,X)
DIMENSION X(5),Y(60)
CALL VFRE(X,N,M,Y)
A=0.0
DO 10 I=1,M
10 A=A+Y(I)*Y(I)
A=SQRT(A/FLOAT(M))
C WRITE(*,5) A,(X(J),J=1,N)
5 FORMAT(2X,'S9=',E12.6,2X,'X(1)=',E12.6,2X,'X(2)=',E12.6,2X,
* 'X(3)=',E12.6)
SIGAMY=A
RETURN
END
F 币
贡献
权杖
窥视卡
发表于 2016-3-5 13:02:14
微信
收藏
点赞
点踩
提升卡
置顶卡
变色卡
千斤顶
显身卡