C==================================================================== C May 2, 2001: modified by Ryo Akasaka for ver.12.1 C The following 18 functions were added but not implemented. C AKPD(8A), AKPDD(8B), AKTD(8C), AKTDD(8D), CVPD(7A), CVTD(7B), C EPSPD(2A), EPSPDD(2B), EPSTD(2C), EPSTDD(2D), GAMPD(9A), C GAMTD(9B), TPH2(6H), TPS2(6S), WPD(8E), WPDD(8F), WTD(8G), C WTDD(8H) C C------------------------------------------------- F8A = AKPD REAL FUNCTION AKPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='AKPD' IF (MESS.NE.0) CALL S99NBU(FUN) AKPD=-1.0E+30 RETURN END C------------------------------------------------- F8B = AKPDD REAL FUNCTION AKPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='AKPDD' IF (MESS.NE.0) CALL S99NBU(FUN) AKPDD=-1.0E+30 RETURN END C------------------------------------------------- F8C = AKTD REAL FUNCTION AKTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='AKTD' IF (MESS.NE.0) CALL S99NBU(FUN) AKTD=-1.0E+30 RETURN END C------------------------------------------------- F8D = AKTDD REAL FUNCTION AKTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='AKTDD' IF (MESS.NE.0) CALL S99NBU(FUN) AKTDD=-1.0E+30 RETURN END C------------------------------------------------- F7A = CVPD REAL FUNCTION CVPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='CVPD' IF (MESS.NE.0) CALL S99NBU(FUN) CVPD=-1.0E+30 RETURN END C------------------------------------------------- F7B = CVTD REAL FUNCTION CVTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='CVTD' IF (MESS.NE.0) CALL S99NBU(FUN) CVTD=-1.0E+30 RETURN END C------------------------------------------------- F2A = EPSPD REAL FUNCTION EPSPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='EPSPD' IF (MESS.NE.0) CALL S99NBU(FUN) EPSPD=-1.0E+30 RETURN END C------------------------------------------------- F2B = EPSPDD REAL FUNCTION EPSPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='EPSPDD' IF (MESS.NE.0) CALL S99NBU(FUN) EPSPDD=-1.0E+30 RETURN END C------------------------------------------------- F2C = EPSTD REAL FUNCTION EPSTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='EPSTD' IF (MESS.NE.0) CALL S99NBU(FUN) EPSTD=-1.0E+30 RETURN END C------------------------------------------------- F2D = EPSTDD REAL FUNCTION EPSTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='EPSTDD' IF (MESS.NE.0) CALL S99NBU(FUN) EPSTDD=-1.0E+30 RETURN END C------------------------------------------------- F9A = GAMPD REAL FUNCTION GAMPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='GAMPD' IF (MESS.NE.0) CALL S99NBU(FUN) GAMPD=-1.0E+30 RETURN END C------------------------------------------------- F9B = GAMTD REAL FUNCTION GAMTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='GAMTD' IF (MESS.NE.0) CALL S99NBU(FUN) GAMTD=-1.0E+30 RETURN END C------------------------------------------------- F6H = TPH2 REAL FUNCTION TPH2(P,H) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='TPH2' IF (MESS.NE.0) CALL S99NBU(FUN) TPH2=-1.0E+30 RETURN END C------------------------------------------------- F6S = TPS2 REAL FUNCTION TPS2(P,S) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='TPS2' IF (MESS.NE.0) CALL S99NBU(FUN) TPS2=-1.0E+30 RETURN END C------------------------------------------------- F8E = WPD REAL FUNCTION WPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='WPD' IF (MESS.NE.0) CALL S99NBU(FUN) WPD=-1.0E+30 RETURN END C------------------------------------------------- F8F = WPDD REAL FUNCTION WPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='WPDD' IF (MESS.NE.0) CALL S99NBU(FUN) WPDD=-1.0E+30 RETURN END C------------------------------------------------- F8G = WTD REAL FUNCTION WTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='WTD' IF (MESS.NE.0) CALL S99NBU(FUN) WTD=-1.0E+30 RETURN END C------------------------------------------------- F8H = WTDD REAL FUNCTION WTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS FUN='WTDD' IF (MESS.NE.0) CALL S99NBU(FUN) WTDD=-1.0E+30 RETURN END C C==================================================================== C------------------------------------------------- F1 = AIPPT FUNCTION AIPPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AIPPT'/ CALL S99NBU(FUN) AIPPT=-1.0E+30 RETURN END C------------------------------------------------- F2 = ALAPP FUNCTION ALAPP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALAPP'/ CALL S99NBU(FUN) ALAPP=-1.0E+30 RETURN END C------------------------------------------------- F3 = ALAPT FUNCTION ALAPT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALAPT'/ CALL S99NBU(FUN) ALAPT=-1.0E+30 RETURN END C------------------------------------------------- F4 = ALHP REAL FUNCTION ALHP(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F4NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHP'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F4NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- ALHP=FF RETURN END C------------------------------------------------- F5 = ALHT REAL FUNCTION ALHT(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F5NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHT'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F5NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- ALHT=FF RETURN END C------------------------------------------------- F6 = ALMPD FUNCTION ALMPD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMPD'/ CALL S99NBU(FUN) ALMPD=-1.0E+30 RETURN END C------------------------------------------------- F7 = ALMPDD FUNCTION ALMPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMPDD'/ CALL S99NBU(FUN) ALMPDD=-1.0E+30 RETURN END C------------------------------------------------- F8 = ALMPT FUNCTION ALMPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMPT'/ CALL S99NBU(FUN) ALMPT=-1.0E+30 RETURN END C------------------------------------------------- F9 = ALMTD FUNCTION ALMTD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMTD'/ CALL S99NBU(FUN) ALMTD=-1.0E+30 RETURN END C------------------------------------------------- F10 = ALMTDD FUNCTION ALMTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMTDD'/ CALL S99NBU(FUN) ALMTDD=-1.0E+30 RETURN END C------------------------------------------------- F11 = AMUPD FUNCTION AMUPD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUPD'/ CALL S99NBU(FUN) AMUPD=-1.0E+30 RETURN END C------------------------------------------------- F12 = AMUPDD FUNCTION AMUPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUPDD'/ CALL S99NBU(FUN) AMUPDD=-1.0E+30 RETURN END C------------------------------------------------- F13 = AMUPT FUNCTION AMUPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUPT'/ CALL S99NBU(FUN) AMUPT=-1.0E+30 RETURN END C------------------------------------------------- F14 = AMUTD FUNCTION AMUTD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUTD'/ CALL S99NBU(FUN) AMUTD=-1.0E+30 RETURN END C------------------------------------------------- F15 = AMUTDD FUNCTION AMUTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUTDD'/ CALL S99NBU(FUN) AMUTDD=-1.0E+30 RETURN END C------------------------------------------------- F16 = CPPD REAL FUNCTION CPPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F16NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F16NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPPD=FF RETURN END C------------------------------------------------- F17 = CPPDD REAL FUNCTION CPPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F17NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPDD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F17NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPPDD=FF RETURN END C------------------------------------------------- F18 = CPPT REAL FUNCTION CPPT(P,T) CHARACTER FUN*6 REAL P,T,FF INTEGER KPA DOUBLE PRECISION F18NBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPT'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) TI=G99NBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F18NBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPPT=FF RETURN END C------------------------------------------------- F19 = CPTD REAL FUNCTION CPTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F19NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPTD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F19NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPTD=FF RETURN END C------------------------------------------------- F20 = CPTDD REAL FUNCTION CPTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F20NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPTDD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F20NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPTDD=FF RETURN END C------------------------------------------------- F21 = CRP REAL FUNCTION CRP(A) CHARACTER FUN*6,FLUID*8,A*1 REAL T0K,PBAR,FF INTEGER KPA DOUBLE PRECISION F21NBU COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FLUID/'NORMAL BUTANE'/, FUN/'CRP'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF C--- FUNCTION CALL --- FF = F21NBU(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF(MESS.NE.0) THEN WRITE(6,6010) FUN,FLUID,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A, & ' WHEN A =',A,' ****') FF=-1.0E+20 END IF END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=FF+T0K ELSE IF(A.EQ.'P') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=FF/PBAR END IF CRP=FF RETURN END C------------------------------------------------- F22 = EPSPT FUNCTION EPSPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'EPSPT'/ CALL S99NBU(FUN) EPSPT=-1.0E+30 RETURN END C------------------------------------------------- F89 = FC C************************************************ C FUNCTION FOR FUNDDAMENTAL CONSTANTS C PROPATH VER.10.1, JULY 31, 1996 C USAGE: B=FC(A) C A, B : CHARACTER TYPE VALIABLES C B='58.1243' WHEN A='M' C B='143.05' WHEN A='R' C************************************************ REAL FUNCTION FC(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'M') THEN FC=58.1243 ELSE IF (A.EQ.'R') THEN FC=143.05 ELSE FC=-1.E+20 IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT FC FOR NORMAL BUTANE WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F23 = HPD REAL FUNCTION HPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F23NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F23NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPD=FF RETURN END C------------------------------------------------- F24 = HPDD REAL FUNCTION HPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F24NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPDD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F24NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPDD=FF RETURN END C------------------------------------------------- F25 = HPT REAL FUNCTION HPT(P,T) CHARACTER FUN*6 REAL P,T,FF INTEGER KPA DOUBLE PRECISION F25NBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPT'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) TI=G99NBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F25NBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPT=FF RETURN END C------------------------------------------------- F26 = HPX FUNCTION HPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'HPX'/ CALL S99NBU(FUN) HPX=-1.0E+30 RETURN END C------------------------------------------------- F27 = HTD REAL FUNCTION HTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F27NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F27NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HTD=FF RETURN END C------------------------------------------------- F28 = HTDD REAL FUNCTION HTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F28NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTDD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F28NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HTDD=FF RETURN END C------------------------------------------------- F29 = HTX FUNCTION HTX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'HTX'/ CALL S99NBU(FUN) HTX=-1.0E+30 RETURN END C------------------------------------------------- F84 = IDENTF C************************************************ C FUNCTION FOR IDENTIFICATION OF SUBSTANCE C PROPATH VER.12.1, MAY 2, 2001 C USAGE: B=IDENTF(A) C A, B : CHARACTER TYPE VALIABLES C B='NORMAL BUTANE' WHEN A='S' C B='CH3CH2CH2CH3' WHEN A='C' C B='12.1' WHEN A='V' C************************************************ CHARACTER*20 FUNCTION IDENTF(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'S') THEN IDENTF='NORMAL BUTANE' ELSE IF (A.EQ.'C') THEN IDENTF='CH3CH2CH2CH3' ELSE IF (A.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT IDENTF FOR NORMAL BUTANE WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F30 = PST REAL FUNCTION PST(T) CHARACTER FUN*6 REAL PBAR,T0K,T,FF INTEGER KPA DOUBLE PRECISION F30NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PST'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF TI=T-T0K DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F30NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PST=FF/PBAR RETURN END C------------------------------------------------- F31 = SIGP FUNCTION SIGP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'SIGP'/ CALL S99NBU(FUN) SIGP=-1.0E+30 RETURN END C------------------------------------------------- F32 = SIGT FUNCTION SIGT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'SIGT'/ CALL S99NBU(FUN) SIGT=-1.0E+30 RETURN END C------------------------------------------------- F33 = SPD REAL FUNCTION SPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F33NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F33NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPD=FF RETURN END C------------------------------------------------- F34 = SPDD REAL FUNCTION SPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F34NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPDD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F34NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPDD=FF RETURN END C------------------------------------------------- F35 = SPT REAL FUNCTION SPT(P,T) CHARACTER FUN*6 REAL P,T,FF INTEGER KPA DOUBLE PRECISION F35NBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPT'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) TI=G99NBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F35NBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPT=FF RETURN END C------------------------------------------------- F36 = SPX FUNCTION SPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'SPX'/ CALL S99NBU(FUN) SPX=-1.0E+30 RETURN END C------------------------------------------------- F37 = STD REAL FUNCTION STD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F37NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F37NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- STD=FF RETURN END C------------------------------------------------- F38 = STDD REAL FUNCTION STDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F38NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STDD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F38NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- STDD=FF RETURN END C------------------------------------------------- F39 = STX FUNCTION STX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'STX'/ CALL S99NBU(FUN) STX=-1.0E+30 RETURN END C------------------------------------------------- F40 = TSP REAL FUNCTION TSP(P) CHARACTER FUN*6 REAL PBAR,T0K,P,FF INTEGER KPA DOUBLE PRECISION F40NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TSP'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F40NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TSP=FF+T0K RETURN END C------------------------------------------------- F41 = TRPL REAL FUNCTION TRPL(A) CHARACTER FUN*6,FLUID*8,A*1 REAL T0K,PBAR,FF INTEGER KPA DOUBLE PRECISION F41NBU COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FLUID/'NORMAL BUTANE'/, FUN/'TRPL'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF C--- FUNCTION CALL --- FF = F41NBU(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF(MESS.NE.0) THEN WRITE(6,6010) FUN,FLUID,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A, & ' WHEN A =',A,' ****') FF=-1.0E+20 END IF END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=FF+T0K ELSE IF(A.EQ.'P') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=FF/PBAR END IF TRPL=FF RETURN END C------------------------------------------------- F42 = UPD REAL FUNCTION UPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F42NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F42NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPD=FF RETURN END C------------------------------------------------- F43 = UPDD REAL FUNCTION UPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F43NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPDD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F43NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPDD=FF RETURN END C------------------------------------------------- F44 = UPT REAL FUNCTION UPT(P,T) CHARACTER FUN*6 REAL P,T,FF INTEGER KPA DOUBLE PRECISION F44NBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPT'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) TI=G99NBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F44NBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPT=FF RETURN END C------------------------------------------------- F45 = UPX FUNCTION UPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'UPX'/ CALL S99NBU(FUN) UPX=-1.0E+30 RETURN END C------------------------------------------------- F46 = UTD REAL FUNCTION UTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F46NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F46NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UTD=FF RETURN END C------------------------------------------------- F47 = UTDD REAL FUNCTION UTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F47NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTDD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F47NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UTDD=FF RETURN END C------------------------------------------------- F48 = UTX FUNCTION UTX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'UTX'/ CALL S99NBU(FUN) UTX=-1.0E+30 RETURN END C------------------------------------------------- F49 = VPD REAL FUNCTION VPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F49NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F49NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPD=FF RETURN END C------------------------------------------------- F50 = VPDD REAL FUNCTION VPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F50NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPDD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F50NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPDD=FF RETURN END C------------------------------------------------- F51 = VPT REAL FUNCTION VPT(P,T) CHARACTER FUN*6 REAL P,T,FF INTEGER KPA DOUBLE PRECISION F51NBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPT'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) TI=G99NBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F51NBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPT=FF RETURN END C------------------------------------------------- F52 = VPX FUNCTION VPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'VPX'/ CALL S99NBU(FUN) VPX=-1.0E+30 RETURN END C------------------------------------------------- F53 = VTD REAL FUNCTION VTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F53NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F53NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VTD=FF RETURN END C------------------------------------------------- F54 = VTDD REAL FUNCTION VTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F54NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTDD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F54NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VTDD=FF RETURN END C------------------------------------------------- F55 = VTX FUNCTION VTX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'VTX'/ CALL S99NBU(FUN) VTX=-1.0E+30 RETURN END C------------------------------------------------- F56 = XPH FUNCTION XPH(P,H) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPH'/ CALL S99NBU(FUN) XPH=-1.0E+30 RETURN END C------------------------------------------------- F57 = XPS REAL FUNCTION XPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPS'/ CALL S99NBU(FUN) XPS=-1.0E+30 RETURN END C------------------------------------------------- F58 = XPU FUNCTION XPU(P,U) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPU'/ CALL S99NBU(FUN) XPU=-1.0E+30 RETURN END C------------------------------------------------- F59 = XPV FUNCTION XPV(P,V) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPV'/ CALL S99NBU(FUN) XPV=-1.0E+30 RETURN END C------------------------------------------------- F60 = XTH FUNCTION XTH(T,H) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTH'/ CALL S99NBU(FUN) XTH=-1.0E+30 RETURN END C------------------------------------------------- F61 = XTS FUNCTION XTS(T,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTS'/ CALL S99NBU(FUN) XTS=-1.0E+30 RETURN END C------------------------------------------------- F62 = XTU FUNCTION XTU(T,U) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTU'/ CALL S99NBU(FUN) XTU=-1.0E+30 RETURN END C------------------------------------------------- F63 = XTV FUNCTION XTV(T,V) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTV'/ CALL S99NBU(FUN) XTV=-1.0E+30 RETURN END C------------------------------------------------- F64 = TPH FUNCTION TPH(P,H) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPH'/ CALL S99NBU(FUN) TPH=-1.0E+30 RETURN END C------------------------------------------------- F65 = TPS FUNCTION TPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPS'/ CALL S99NBU(FUN) TPS=-1.0E+30 RETURN END C------------------------------------------------- F66 = PLDT FUNCTION PLDT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PLDT'/ CALL S99NBU(FUN) PLDT=-1.0E+30 RETURN END C------------------------------------------------- F67 = TLDP FUNCTION TLDP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TLDP'/ CALL S99NBU(FUN) TLDP=-1.0E+30 RETURN END C------------------------------------------------- F68 = PMLT REAL FUNCTION PMLT(T) CHARACTER FUN*6 REAL PBAR,T0K,T,FF INTEGER KPA DOUBLE PRECISION F68NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PMLT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF TI=T-T0K DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F68NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PMLT=FF/PBAR RETURN END C------------------------------------------------- F69 = TMLP REAL FUNCTION TMLP(P) CHARACTER FUN*6 REAL PBAR,T0K,P,FF INTEGER KPA DOUBLE PRECISION F69NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TMLP'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F69NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TMLP=FF+T0K RETURN END C------------------------------------------------- F70 = TPV FUNCTION TPV(P,V) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPV'/ CALL S99NBU(FUN) TPV=-1.0E+30 RETURN END C------------------------------------------------- F71 = HPS FUNCTION HPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'HPS'/ CALL S99NBU(FUN) HPS=-1.0E+30 RETURN END C------------------------------------------------- F72 = PSTD FUNCTION PSTD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PSTD'/ CALL S99NBU(FUN) PSTD=-1.0E+30 RETURN END C------------------------------------------------- F73 = PSTDD FUNCTION PSTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PSTDD'/ CALL S99NBU(FUN) PSTDD=-1.0E+30 RETURN END C------------------------------------------------- F74 = TSPD FUNCTION TSPD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TSPD'/ CALL S99NBU(FUN) TSPD=-1.0E+30 RETURN END C------------------------------------------------- F75 = TSPDD FUNCTION TSPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TSPDD'/ CALL S99NBU(FUN) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F76 = CVPDD REAL FUNCTION CVPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F76NBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CVPDD'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F76NBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CVPDD=FF RETURN END C------------------------------------------------- F77= CVPT REAL FUNCTION CVPT(P,T) CHARACTER FUN*6 REAL P,T,FF INTEGER KPA DOUBLE PRECISION F77NBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CVPT'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) TI=G99NBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F77NBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CVPT=FF RETURN END C------------------------------------------------- F78 = CVTDD REAL FUNCTION CVTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F78NBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CVTDD'/ C--- SET OF UNIT --- TI=G99NBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F78NBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CVTDD=FF RETURN END C------------------------------------------------- F79 = UPS FUNCTION UPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'UPS'/ CALL S99NBU(FUN) UPS=-1.0E+30 RETURN END C------------------------------------------------- F80 = VPS FUNCTION VPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'VPS'/ CALL S99NBU(FUN) VPS=-1.0E+30 RETURN END C------------------------------------------------- F81= PRPT FUNCTION PRPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRPT'/ CALL S99NBU(FUN) PRPT=-1.0E+30 RETURN END C------------------------------------------------- F82= AKPT FUNCTION AKPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AKPT'/ CALL S99NBU(FUN) AKPT=-1.0E+30 RETURN END C------------------------------------------------- F83= WPT REAL FUNCTION WPT(P,T) CHARACTER FUN*6 REAL P,T,FF INTEGER KPA DOUBLE PRECISION F83NBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'WPT'/ C--- SET OF UNIT --- PI=G98NBU(KPA,P) TI=G99NBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F83NBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97NBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98NBU(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- WPT=FF RETURN END *------------------------------------------------- F85 = PRPD REAL FUNCTION PRPD(P) REAL P,PI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRPD'/ PI=P CALL S99NBU(FUN) PRPD=-1.0E+30 RETURN END *------------------------------------------------- F86 = PRPDD REAL FUNCTION PRPDD(P) REAL P,PI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRPDD'/ PI=P CALL S99NBU(FUN) PRPDD=-1.0E+30 RETURN END *------------------------------------------------- F87 = PRTD REAL FUNCTION PRTD(T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRTD'/ TI=T CALL S99NBU(FUN) PRTD=-1.0E+30 RETURN END *------------------------------------------------- F88 = PRTDD REAL FUNCTION PRTDD(T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRTDD'/ TI=T CALL S99NBU(FUN) PRTDD=-1.0E+30 RETURN END *------------------------------------------------- F90= BSPT REAL FUNCTION BSPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BSPT'/ TI=T CALL S99NBU(FUN) BSPT=-1.0E+30 RETURN END *------------------------------------------------- F91= BTPT REAL FUNCTION BTPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BTPT'/ TI=T CALL S99NBU(FUN) BTPT=-1.0E+30 RETURN END *------------------------------------------------- F92= BPPT REAL FUNCTION BPPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BPPT'/ TI=T CALL S99NBU(FUN) BPPT=-1.0E+30 RETURN END *------------------------------------------------- F93= BVPT REAL FUNCTION BVPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BVPT'/ TI=T CALL S99NBU(FUN) BVPT=-1.0E+30 RETURN END *------------------------------------------------- F94= AJTPT REAL FUNCTION AJTPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AJTPT'/ TI=T CALL S99NBU(FUN) AJTPT=-1.0E+30 RETURN END *------------------------------------------------- F95= GAMPT REAL FUNCTION GAMPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'GAMPT'/ TI=T CALL S99NBU(FUN) GAMPT=-1.0E+30 RETURN END *------------------------------------------------- F96 = GAMPDD REAL FUNCTION GAMPDD(P) REAL P,PI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'GAMPDD'/ PI=P CALL S99NBU(FUN) GAMPDD=-1.0E+30 RETURN END *------------------------------------------------- F97 = GAMTDD REAL FUNCTION GAMTDD(T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'GAMTDD'/ TI=T CALL S99NBU(FUN) GAMTDD=-1.0E+30 RETURN END C------------------------------------------------- F98 = TPSEUP FUNCTION TPSEUP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPSEUP'/ CALL S99NBU(FUN) TPSEUP=-1.0E+30 RETURN END C------------------------------------------------- F99 = PSBT FUNCTION PSBT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PSBT'/ CALL S99NBU(FUN) PSBT=-1.0E+30 RETURN END C------------------------------------------------- F100 = TSBP FUNCTION TSBP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TSBP'/ CALL S99NBU(FUN) TSBP=-1.0E+30 RETURN END C C#################################################################### C C******************************************************************** C* ************************************** * C* * A PROGRAM PACKAGE OF NORMAL BUTANE * * C* ************************************** * C* * C* ***************** ATTENTION ********************** * C* * T : TEMPERATURE, CELSIUS * * C* * H : SPECIFIC ENTHALPY, J/KG * * C* * P : PRESSURE, BAR * * C* * S : SPECIFIC ENTROPY, J/KG/K * * C* * U : SPECIFIC INTERNAL ENERGY, J/KG * * C* * V : SPECIFIC VOLUME, CU.M/KG * * C* ************************************************** * C* * C******************************************************************** C C *** ALHP(P) LATENT HEAT OF VAPORIZATION DOUBLE PRECISION FUNCTION F4NBU(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 HL=F23NBU(P) HV=F24NBU(P) IF(HL.EQ.-1.0E+20.OR.HV.EQ.-1.0E+20) GO TO 900 F4NBU=HV-HL RETURN 600 F4NBU=-1.0E+20 RETURN 900 F4NBU=-1.0E+20 RETURN END C *** ALHT(T) LATENT HEAT OF VAPORIZATION DOUBLE PRECISION FUNCTION F5NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 HL=F27NBU(T) HV=F28NBU(T) IF(HL.EQ.-1.0E+20.OR.HV.EQ.-1.0E+20) GO TO 900 F5NBU=HV-HL RETURN 600 F5NBU=-1.0E+20 RETURN 900 F5NBU=-1.0E+20 RETURN END C *** CPPD(P) SPECIFIC HEAT CAPACITY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F16NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA TCRT /425.16D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F49NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 CALL S03NBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S12NBU(TM,CSATXF) CSAT = CSATXF CALL S04NBU(TM,DL,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) IF(TM.LT.355.0D00) GO TO 22 CALL S13NBU(TM,CVSATF) CV = CVSATF GO TO 23 22 CV = CSAT + 100.0D00*TM*DPDT*DDLDT/DL/DL 23 CP = CV + 100.0D00*TM/DPDD*(DPDT/DL)**2 F16NBU=CP*(1.0D03/WM) RETURN 300 F16NBU=+1.0E+20 RETURN 600 F16NBU=-1.0E+20 RETURN 900 F16NBU=-1.0E+20 RETURN END C *** CPPDD(P) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F17NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA TCRT /425.16D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F50NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV CALL S04NBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CPG = CVG + 100.0D00*TM/DPDD*(DPDT/DB)**2 F17NBU=CPG*(1.0D03/WM) RETURN 300 F17NBU=+1.0E+20 RETURN 600 F17NBU=-1.0E+20 RETURN 900 F17NBU=-1.0E+20 RETURN END C *** CPPT(P,T) SPECIFIC HEAT CAPACITY DOUBLE PRECISION FUNCTION F18NBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA TTRP,TCRT /134.86D00,425.16D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69NBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.6.738D-06.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51NBU(P,T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TM=T+273.15D00 C TTCRT=SNGL(TCRT) TTM=SNGL(TM) C IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 IF(P.LT.PCRT) THEN TSS=F40NBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,20,20 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,20,20 END IF C 2 ALOL=F53NBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DA=1.0D00/(ALOL*WM) CALL S19NBU(TM,CVL) CV=CVL DX = DB-DA IF(DX) 13,13,11 11 N = DX*10 + 5 CALL S11NBU(0,N,TM,DA,DB,EDELF,DELS,DELCV) CV = CV + DELCV 13 CALL S04NBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CP = CV + 100.0D00*TM/DPDD*(DPDT/DB)**2 GO TO 100 C 20 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.D00,DB,EDELF,DELS,DELCV) CV = CVZ + DELCV CALL S04NBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CP = CV + 100.0D00*TM/DPDD*(DPDT/DB)**2 100 F18NBU=CP*(1.0D03/WM) RETURN 300 F18NBU=+1.0E+20 RETURN 600 F18NBU=-1.0E+20 RETURN 900 F18NBU=-1.0E+20 RETURN END C *** CPTD(T) SPECIFIC HEAT CAPACITY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F19NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 ALO=F53NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) CALL S03NBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S12NBU(TM,CSATXF) CSAT = CSATXF CALL S04NBU(TM,DL,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) IF(TM.LT.355.0D00) GO TO 22 CALL S13NBU(TM,CVSATF) CV = CVSATF GO TO 23 22 CV = CSAT + 100.0D00*TM*DPDT*DDLDT/DL/DL 23 CP = CV + 100.0D00*TM/DPDD*(DPDT/DL)**2 F19NBU=CP*(1.0D03/WM) RETURN 300 F19NBU=+1.0E+20 RETURN 600 F19NBU=-1.0E+20 RETURN 900 F19NBU=-1.0E+20 RETURN END C *** CPTDD(T) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F20NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 ALO=F54NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV CALL S04NBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CPG = CVG + 100.0D00*TM/DPDD*(DPDT/DB)**2 F20NBU=CPG*(1.0D03/WM) RETURN 300 F20NBU=+1.0E+20 RETURN 600 F20NBU=-1.0E+20 RETURN 900 F20NBU=-1.0E+20 RETURN END C *** CRP(A) QUANTITIES AT THE CRITICAL POINT DOUBLE PRECISION FUNCTION F21NBU(A) CHARACTER*1 A,B(5) DATA B/'H','P','S','T','V'/ IF((A.EQ.B(1)).OR.(A.EQ.B(2)).OR.(A.EQ.B(3)).OR. & (A.EQ.B(4)).OR.(A.EQ.B(5))) GO TO 5 GO TO 900 5 IF(A.NE.B(1)) GO TO 10 F21NBU=783.5D03 RETURN 10 IF(A.NE.B(2)) GO TO 20 F21NBU=37.9612D00 RETURN 20 IF(A.NE.B(3)) GO TO 30 F21NBU=5.129D03 RETURN 30 IF(A.NE.B(4)) GO TO 40 F21NBU=152.01D00 RETURN 40 IF(A.NE.B(5)) GO TO 900 F21NBU=4.41D-03 RETURN 900 F21NBU=-1.0E+20 RETURN END C *** HPD(P) SPECIFIC ENTHALPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F23NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-08/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 IF(DABS((P-PTRP)/PTRP).LT.DLT) GO TO 300 ALO=F49NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 CALL S03NBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18NBU(TM,QVAPXF) QV=QVAPXF HG=F24NBU(P) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV F23NBU=H*(1.0D03/WM) RETURN 300 CONTINUE ALO=F49NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/ALO PS=P UL=F42NBU(P) IF(UL.EQ.-1.0E+20) GO TO 900 HL = UL + 1.0D05*PS/DL F23NBU= HL RETURN 600 F23NBU=-1.0E+20 RETURN 900 F23NBU=-1.0E+20 RETURN END C *** HPDD(P) SPECIFIC ENTHALPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F24NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA WM/58.1243D00/ DATA EZZ/22580.9D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 PS = P ALO=F50NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF HG = EG + 100.0D00*PS/DB F24NBU=HG*(1.0D03/WM) RETURN 600 F24NBU=-1.0E+20 RETURN 900 F24NBU=-1.0E+20 RETURN END C *** HPT(P,T) SPECIFIC ENTHALPY DOUBLE PRECISION FUNCTION F25NBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA TTRP,TCRT /134.86D00,425.16D00/ DATA WM/58.1243D00/ DATA EZZ/22580.9D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69NBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.6.738D-06.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51NBU(P,T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TM=T+273.15D00 C TTCRT=SNGL(TCRT) TTM=SNGL(TM) C IF(P.LT.PCRT) THEN TSS=F40NBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,20,20 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,20,20 END IF C 2 ALOL=F53NBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DA=1.0D00/(ALOL*WM) ULL=F46NBU(T) UL=ULL/(1.0D03/WM) DX = DB-DA IF(DX) 13,13,11 11 N = DX*10 + 5 CALL S11NBU(0,N,TM,DA,DB,EDELF,DELS,DELCV) U = UL + EDELF GO TO 14 13 U = UL 14 PS=P H = U + 100.0D00*PS/DB GO TO 100 C 20 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.D00,DB,EDELF,DELS,DELCV) U = EZZ + EZ + EDELF PS=P H = U + 100.0D00*PS/DB 100 F25NBU=H*(1.0D03/WM) RETURN 600 F25NBU=-1.0E+20 RETURN 900 F25NBU=-1.0E+20 RETURN END C *** HTD(T) SPECIFIC ENTHALPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F27NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ DATA DLT/1.0D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TTRP)/TTRP).LT.DLT) GO TO 300 ALO=F53NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) CALL S03NBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18NBU(TM,QVAPXF) QV=QVAPXF HG=F28NBU(T) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV F27NBU=H*(1.0D03/WM) RETURN 300 CONTINUE ALO=F53NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/ALO PS=F30NBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 UL=F46NBU(T) IF(UL.EQ.-1.0E+20) GO TO 900 HL = UL + 1.0D05*PS/DL F27NBU= HL RETURN 600 F27NBU=-1.0E+20 RETURN 900 F27NBU=-1.0E+20 RETURN END C *** HTDD(T) SPECIFIC ENTHALPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F28NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ DATA EZZ/22580.9D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 ALO=F54NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) PS=F30NBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF HG = EG + 100.0D00*PS/DB F28NBU=HG*(1.0D03/WM) RETURN 600 F28NBU=-1.0E+20 RETURN 900 F28NBU=-1.0E+20 RETURN END C *** PST(T) SATURATION PRESSURE DOUBLE PRECISION FUNCTION F30NBU(T) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA EPP,TCRT,A,B/1.85D00,425.16D00,14.45037296D00,9.50878339D00/ DATA TTRP/134.86D000/ DATA PCRT/37.961199413D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA C,D,E,F /-35.95072289D00, 41.89821096D00,-16.76129646D00, 1 11.70758279D00/ DATA DLT/2.5D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 X = TM/TCRT X2 = X*X U = 1.0D00 - 1.0D00/X V = 1.0D00 - X IF(DABS((TM-TCRT)/TCRT).LT.DLT) THEN Z = 0.0D00 GO TO 10 END IF Z = V**EPP 10 CONTINUE PL = A + B*U + C*X + D*X2 + E*X*X2 + F*X*Z PSATF = DEXP(PL) F30NBU=PSATF RETURN 300 F30NBU=PCRT RETURN 600 F30NBU=-1.0E+20 RETURN END C *** SPD(P) SPECIFIC ENTROPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F33NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA WM/58.1243D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F49NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 CALL S03NBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18NBU(TM,QVAPXF) QV=QVAPXF SG=F34NBU(P) IF(SG.EQ.-1.0E+20) GO TO 900 S=SG*WM/1.0D03-QV/TM F33NBU=S*(1.0D03/WM) RETURN 600 F33NBU=-1.0E+20 RETURN 900 F33NBU=-1.0E+20 RETURN END C *** SPDD(P) SPECIFIC ENTROPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F34NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA Q,G/1.01325D00,0.083145D00/ DATA WM/58.1243D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F50NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) SG = SZ + DELS - 100.0D00*G*DLOG(G*TM*DB/Q) F34NBU=SG*(1.0D03/WM) RETURN 600 F34NBU=-1.0E+20 RETURN 900 F34NBU=-1.0E+20 RETURN END C *** SPT(P,T) SPECIFIC ENTROPY DOUBLE PRECISION FUNCTION F35NBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA TTRP,TCRT /134.86D00,425.16D00/ DATA WM/58.1243D00/ DATA Q,G/1.01325D00,0.083145D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69NBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.6.738D-06.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51NBU(P,T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TM=T+273.15D00 C TTCRT=SNGL(TCRT) TTM=SNGL(TM) C IF(P.LT.PCRT) THEN TSS=F40NBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,20,20 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,20,20 END IF C 2 ALOL=F53NBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DA=1.0D00/(ALOL*WM) SLL=F37NBU(T) SL=SLL/(1.0D03/WM) DX = DB-DA IF(DX) 13,13,11 11 N = DX*10 + 5 CALL S11NBU(0,N,TM,DA,DB,EDELF,DELS,DELCV) S = SL + DELS GO TO 14 13 S = SL 14 GO TO 100 C 20 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.D00,DB,EDELF,DELS,DELCV) S = SZ + DELS - 100.0D00*G*DLOG(G*TM*DB/Q) 100 F35NBU=S*(1.0D03/WM) RETURN 600 F35NBU=-1.0E+20 RETURN 900 F35NBU=-1.0E+20 RETURN END C *** STD(T) SPECIFIC ENTROPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F37NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 ALO=F53NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) CALL S03NBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18NBU(TM,QVAPXF) QV=QVAPXF SG=F38NBU(T) IF(SG.EQ.-1.0E+20) GO TO 900 S=SG*WM/1.0D03-QV/TM F37NBU=S*(1.0D03/WM) RETURN 600 F37NBU=-1.0E+20 RETURN 900 F37NBU=-1.0E+20 RETURN END C *** STDD(T) SPECIFIC ENTROPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F38NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA Q,G/1.01325D00,0.083145D00/ DATA WM/58.1243D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 ALO=F54NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) PS=F30NBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) SG = SZ + DELS - 100.0D00*G*DLOG(G*TM*DB/Q) F38NBU=SG*(1.0D03/WM) RETURN 600 F38NBU=-1.0E+20 RETURN 900 F38NBU=-1.0E+20 RETURN END C *** TSP(P) SATURATION TEMPERATURE DOUBLE PRECISION FUNCTION F40NBU(P) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA TCRT/425.16D00/ DATA DLT/2.5D-07/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 IF(DABS((P-PCRT)/PCRT).LT.DLT) GO TO 300 T = 300.0D00 DO 9 J=1,50 T1=T-273.15D00 DPP=F30NBU(T1) IF(DPP.EQ.-1.0E+20) GO TO 900 DP = P - DPP ADP = DABS (DP) CALL S01NBU(T,PSATF,DPSDT) IF(ADP/P-1.0D-7) 10,6,6 6 IF(ADP/DPSDT/T-1.0D-7) 10,7,7 7 T = T + DP/DPSDT IF(T-TCRT) 9,9,8 8 T = TCRT 9 CONTINUE 10 FINDTS = T F40NBU=FINDTS-273.15D00 RETURN 300 F40NBU=TCRT-273.15D00 RETURN 600 F40NBU=-1.0E+20 RETURN 900 F40NBU=-1.0E+20 RETURN END C *** TRPL(A) QUANTITIES AT THE TRIPLE POINT DOUBLE PRECISION FUNCTION F41NBU(A) CHARACTER*1 A,B(2) DATA B/'P','T'/ IF (A.EQ.B(1).OR.A.EQ.B(2)) GO TO 5 GO TO 900 5 IF(A.NE.B(1)) GO TO 10 F41NBU=6.738D-06 RETURN 10 IF(A.NE.B(2)) GO TO 900 F41NBU=-138.29D00 RETURN 900 F41NBU=-1.0E+20 RETURN END C *** UPD(P) SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F42NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-08/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 IF(DABS((P-PTRP)/PTRP).LT.DLT) GO TO 300 ALO=F49NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 PS=P TM=T+273.15D00 CALL S03NBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18NBU(TM,QVAPXF) QV=QVAPXF HG=F24NBU(P) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV E = H - 100.0D00*PS/DL F42NBU=E*(1.0D03/WM) RETURN 300 F42NBU= 0.0D00 RETURN 600 F42NBU=-1.0E+20 RETURN 900 F42NBU=-1.0E+20 RETURN END C *** UPDD(P) SPECIFIC INTERNAL ENERGY OF SATURATED VAPPOR DOUBLE PRECISION FUNCTION F43NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA WM/58.1243D00/ DATA EZZ/22580.9D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F50NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF F43NBU=EG*(1.0D03/WM) RETURN 600 F43NBU=-1.0E+20 RETURN 900 F43NBU=-1.0E+20 RETURN END C *** UPT(P,T) SPECIFIC INTERNAL ENERGY DOUBLE PRECISION FUNCTION F44NBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA TTRP,TCRT /134.86D00,425.16D00/ DATA WM/58.1243D00/ DATA EZZ/22580.9D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69NBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.6.738D-06.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51NBU(P,T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TM=T+273.15D00 C TTCRT=SNGL(TCRT) TTM=SNGL(TM) C IF(P.LT.PCRT) THEN TSS=F40NBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,20,20 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,20,20 END IF C 2 ALOL=F53NBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DA=1.0D00/(ALOL*WM) ULL=F46NBU(T) UL=ULL/(1.0D03/WM) DX = DB-DA IF(DX) 13,13,11 11 N = DX*10 + 5 CALL S11NBU(0,N,TM,DA,DB,EDELF,DELS,DELCV) U = UL + EDELF GO TO 14 13 U = UL 14 GO TO 100 C 20 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.D00,DB,EDELF,DELS,DELCV) U = EZZ + EZ + EDELF 100 F44NBU=U*(1.0D03/WM) RETURN 600 F44NBU=-1.0E+20 RETURN 900 F44NBU=-1.0E+20 RETURN END C *** UTD(T) SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F46NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ DATA DLT/1.0D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TTRP)/TTRP).LT.DLT) GO TO 300 ALO=F53NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) PS=F30NBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 CALL S18NBU(TM,QVAPXF) QV=QVAPXF HG=F28NBU(T) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV E = H - 100.0D00*PS/DL F46NBU=E*(1.0D03/WM) RETURN 300 F46NBU= 0.0D00 RETURN 600 F46NBU=-1.0E+20 RETURN 900 F46NBU=-1.0E+20 RETURN END C *** UTDD(T) SPECIFIC INTERNAL ENERGY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F47NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ DATA EZZ/22580.9D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 ALO=F54NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) PS=F30NBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF F47NBU=EG*(1.0D03/WM) RETURN 600 F47NBU=-1.0E+20 RETURN 900 F47NBU=-1.0E+20 RETURN END C *** VPD(P) SPECIFIC VOLUME OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F49NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 F49NBU=F53NBU(T) RETURN 600 F49NBU=-1.0E+20 RETURN 900 F49NBU=-1.0E+20 RETURN END C *** VPDD(P) SPECIFIC VOLUME OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F50NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 F50NBU=F54NBU(T) RETURN 600 F50NBU=-1.0E+20 RETURN 900 F50NBU=-1.0E+20 RETURN END C *** VPT(P,T) SPECIFIC VOLUME DOUBLE PRECISION FUNCTION F51NBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) REAL TTT,TTP,PP,TTM,TTCRT,PPS,PPC DATA DCRT,DTRP,TTRP,TCRT /3.90D00,12.65D00,134.86D00,425.16D00/ DATA WM /58.1243D00/ DATA DM,GKK /13.5,0.083145/ DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ DATA DLT/2.5D-06/ TP=F69NBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.6.738D-06.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 TM=T+273.15D00 C PP=SNGL(P) C TTM=SNGL(TM) TTCRT=SNGL(TCRT) C IF(TTM-TTCRT) 2,5,8 C 2 ALG=F54NBU(T) IF(ALG.EQ.-1.0E+20) GO TO 900 DG=1.0D00/(ALG*WM) ALOL=F53NBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALOL*WM) PS=F30NBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 C PPS=SNGL(PS) C IF(ABS((PP-PPS)/PP).LT.DLT) GO TO 32 C IF(PP.GT.PPS) GO TO 4 C 3 D=DG/2.0D00 GO TO 11 4 D=(DL+DTRP)/2.0D00 GO TO 11 5 DL=DCRT DG=DL PS=PCRT C PPS=SNGL(PS) C IF(PP-PPS) 6,33,7 C 6 D=DCRT/2.0D00 GO TO 11 7 D=2.0D00*DCRT GO TO 11 8 IF(TM.GE.450.0D00) GO TO 10 CALL S04NBU(TM,DCRT,0,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) 9 PC=PVTF C PPC=SNGL(PC) C IF(PP-PPC) 6,33,7 C 10 D=DCRT 11 DO 30 J=1,50 CALL S04NBU(TM,D,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) DP=P-PVTF IF(DABS(DP/P)-1.0D-6) 31,31,12 12 IF(DPDD.LE.0.0D00) GO TO 34 13 DD=DP/DPDD IF(DABS(DD/D)-1.0D-6) 31,31,14 14 D=D+DD IF(D.GT.0.0D00) GO TO 16 15 D=P/GKK/TM GO TO 30 16 IF(D.LE.DM) GO TO 18 17 D=DM GO TO 30 18 IF(TM-TCRT) 19,24,30 C 19 IF(PP.GT.PPS) GO TO 22 C 20 IF(D.LE.DG) GO TO 30 21 D=DG GO TO 30 22 IF(D.GE.DL) GO TO 30 23 D=DL GO TO 30 24 IF(P.GE.PCRT) GO TO 27 25 IF(D.LT.DCRT) GO TO 30 26 D=DCRT-0.02D00 GO TO 30 27 IF(D.GT.DCRT) GO TO 30 28 D=DCRT+0.02D00 30 CONTINUE GO TO 950 31 F51NBU=1.D00/(D*WM*1.0D-3/1.0D-3) RETURN 32 F51NBU=1.D00/(DG*WM*1.0D-3/1.0D-3) RETURN 33 F51NBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 34 F51NBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F51NBU=-1.0E+20 RETURN 900 F51NBU=-1.0E+20 RETURN 950 F51NBU=-1.0E+10 RETURN END C *** VTD(T) SPECIFIC VOLUME OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F53NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DIMENSION AW(3) DATA EL / 0.35D00/ DATA DCRT,DTRP,TTRP,TCRT /3.90D00,12.65D00,134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA AW / 0.802377995D00, -0.139053759D00, 0.057353024D00/ DATA DLT/2.5D-07/ DATA WM/58.1243D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 XN=TCRT-TTRP X=(TCRT-TM)/XN X2 = X*X DXDT = -1.0D00/XN XE = X**EL V = XE - X Y = AW(1) + AW(2)*X2 + AW(3)*X*X2 YNL = DTRP - DCRT DLIQF = DCRT + YNL*(X + V*Y) F53NBU=1.D00/(DLIQF*WM*1.0D-3/1.0D-3) RETURN 300 F53NBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F53NBU=-1.0E+20 RETURN END C *** VTDD(T) SPECIFIC VOLUME OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F54NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DIMENSION AV(3) DATA DCRT,TTRP,TCRT/3.90D00,134.86D00,425.16D00/ DATA PCRT/37.961199413D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA EG, EGX, GKK / 0.35D00, 2.60D00, 0.083145D00 / DATA AV / -0.87075081D00, 1.14934828D00, 99.16551154D00/ DATA DLT/2.5D-07/ DATA WM/58.1243D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 ZCRT = PCRT/DCRT/GKK/TCRT ZN = ZCRT-1.0D00 PC = PCRT P = F30NBU(T) IF(P.EQ.-1.0E+20) GO TO 900 CALL S01NBU(TM,PSATF,DPSDT) PI = P/PC PIT = DPSDT/PC TC = TCRT X = TM/TC X2 = X*X V = 1.0D00-X VE = V**EG EGXV = EGX/V IF(EGXV.LE.290.0D00) GO TO 11 XP = 0.0D00 GO TO 12 11 XP = DEXP(-EGXV) 12 F = 1.0D00 + AV(1)*VE + AV(2)*V + AV(3)*XP ZFX = F ZSM1 = ZN*PI*F/X2 Z = 1.0D00 + ZSM1 DGASF = P/TM/Z/GKK F54NBU=1.D00/(DGASF*WM*1.0D-3/1.0D-3) RETURN 300 F54NBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F54NBU=-1.0E+20 RETURN 900 F54NBU=-1.0E+20 RETURN END C *** PMLT(T) PRESSURE ON THE MELTING LINE DOUBLE PRECISION FUNCTION F68NBU(T) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,TTRP/6.738D-06,134.86D00/ C TC -- TMLP(700 bar) DATA TC/146.05D00/,TL/134.86D00/ DATA TCX/146.051D00/,TLX/134.859D00/ DATA A, E / 3634.0D00, 2.210D00 / DATA DLT/7.0D-08/ TM=T+273.15D00 IF(TM.LT.TLX) GO TO 600 IF(TM.GT.TCX) GO TO 600 X = TM/TTRP XE = X**E IF(DABS((TM-TTRP)/TTRP).LT.DLT) XE=1.0D00 PMELTF = PTRP + A*(XE-1.0D00) F68NBU=PMELTF RETURN 600 F68NBU=-1.0E+20 RETURN END C *** TMLP(P) TEMPERATURE ON THE MELTING LINE DOUBLE PRECISION FUNCTION F69NBU(P) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,TTRP/6.738D-06,134.86D00/ DATA A, E / 3634.0D00, 2.210D00 / DATA PTRPX/6.7379D-06/ IF(P.LT.PTRPX.OR.P.GT.700.001D00) GO TO 600 X = (P-PTRP)/A + 1.0D00 FINDTM = TTRP*X**(1.0D00/E) F69NBU=FINDTM-273.15D00 RETURN 600 F69NBU=-1.0E+20 RETURN END C *** CVPDD(P) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F76NBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA PTRPX,PCRTX/6.7379D-06,37.96121D00/ DATA TCRT /425.16D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F50NBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40NBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV F76NBU=CVG*(1.0D03/WM) RETURN 300 F76NBU=+1.0E+20 RETURN 600 F76NBU=-1.0E+20 RETURN 900 F76NBU=-1.0E+20 RETURN END C *** CVPT(P,T) SPECIFIC HEAT CAPACITY DOUBLE PRECISION FUNCTION F77NBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA TTRP,TCRT /134.86D00,425.16D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69NBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.6.738D-06.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51NBU(P,T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TM=T+273.15D00 C TTCRT=SNGL(TCRT) TTM=SNGL(TM) C IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 IF(P.LT.PCRT) THEN TSS=F40NBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,20,20 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,20,20 END IF C 2 ALOL=F53NBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DA=1.0D00/(ALOL*WM) CALL S19NBU(TM,CVL) CV=CVL DX = DB-DA IF(DX) 13,13,11 11 N = DX*10 + 5 CALL S11NBU(0,N,TM,DA,DB,EDELF,DELS,DELCV) CV = CV + DELCV 13 GO TO 100 C 20 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.D00,DB,EDELF,DELS,DELCV) CV = CVZ + DELCV 100 F77NBU=CV*(1.0D03/WM) RETURN 300 F77NBU=+1.0E+20 RETURN 600 F77NBU=-1.0E+20 RETURN 900 F77NBU=-1.0E+20 RETURN END C *** CVTDD(T) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F78NBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /134.86D00,425.16D00/ DATA TTRPX,TCRTX /134.859D00,425.161D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 ALO=F54NBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV F78NBU=CVG*(1.0D03/WM) RETURN 300 F78NBU=+1.0E+20 RETURN 600 F78NBU=-1.0E+20 RETURN 900 F78NBU=-1.0E+20 RETURN END C *** WPT(P,T) VELOCITY OF SOUND DOUBLE PRECISION FUNCTION F83NBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/6.738D-06,37.961199413D00/ DATA TTRP,TCRT /134.86D00,425.16D00/ DATA WM/58.1243D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69NBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.6.738D-06.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51NBU(P,T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) WK = 100000.0D00/WM TM=T+273.15D00 C TTCRT=SNGL(TCRT) TTM=SNGL(TM) C IF(P.LT.PCRT) THEN TSS=F40NBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,20,20 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,20,20 END IF C 2 ALOL=F53NBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DA=1.0D00/(ALOL*WM) CALL S19NBU(TM,CVL) CV=CVL DX = DB-DA IF(DX) 13,13,11 11 N = DX*10 + 5 CALL S11NBU(0,N,TM,DA,DB,EDELF,DELS,DELCV) CV = CV + DELCV 13 CALL S04NBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CP = CV + 100.0D00*TM/DPDD*(DPDT/DB)**2 W = DSQRT(WK*CP*DPDD/CV) GO TO 100 C 20 TI = TM CALL S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11NBU(1,N,TM,0.D00,DB,EDELF,DELS,DELCV) CV = CVZ + DELCV CALL S04NBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CP = CV + 100.0D00*TM/DPDD*(DPDT/DB)**2 W = DSQRT(WK*CP*DPDD/CV) 100 F83NBU=W RETURN 600 F83NBU=-1.0E+20 RETURN 900 F83NBU=-1.0E+20 RETURN END C C******************************************************************** C* ******************************** * C* * FUNCTION FOR SETTING UNITS * * C* ******************************** * C******************************************************************** C REAL FUNCTION G98NBU(KPA,P) REAL P,PBAR IF(KPA.EQ.1) THEN PBAR=1.0E0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0E0 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 ELSE PBAR=1.0E-05 END IF G98NBU=P*PBAR RETURN END REAL FUNCTION G99NBU(KPA,T) REAL T,T0K IF(KPA.EQ.1) THEN T0K=0.0E0 ELSE IF(KPA.EQ.2) THEN T0K=273.15E0 ELSE IF(KPA.EQ.3) THEN T0K=0.0E0 ELSE T0K=273.15E0 END IF G99NBU=T-T0K RETURN END C C#################################################################### C******************************************************************** C* **************** * C* * SUBROUTINE * * C* **************** * C******************************************************************** C C *** DPSDT SUBROUTINE S01NBU(T,PSATF,DPSDT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA EPP,TCRT,A,B/1.85D00,425.16D00,14.45037296D00,9.50878339D00/ DATA TTRP/134.86D000/ DATA C,D,E,F /-35.95072289D00, 41.89821096D00,-16.76129646D00, 1 11.70758279D00/ DATA DLT/2.5D-07/ X = T/TCRT X2 = X*X X1T = 1.0D00/TCRT U = 1.0D00 - 1.0D00/X U1T = 1.0D00/X/T V = 1.0D00 - X IF(DABS((T-TCRT)/TCRT).LT.DLT) THEN Z1 = 0.0D00 Z = 0.0D00 GO TO 10 END IF Z = V**EPP Z1 = -EPP*Z/V 10 CONTINUE PL = A + B*U + C*X + D*X2 + E*X*X2 + F*X*Z PL1T = B*U1T + (C + 2.0D00*D*X + 3.0D00*E*X2 + F*(X*Z1 + Z))*X1T PSATF = DEXP(PL) DPSDT = PL1T*PSATF RETURN END C C *** DDSDT(V) SUBROUTINE S02NBU(T,DDSDT,ZSAT,ZFX,DGASF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AV(3) COMMON/B13/ ZCRT DATA DCRT,TTRP,TCRT/3.90D00,134.86D00,425.16D00/ DATA PCRT/37.961199413D00/ DATA EG, EGX, GKK / 0.35D00, 2.60D00, 0.083145D00 / DATA AV / -0.87075081D00, 1.14934828D00, 99.16551154D00/ DATA DLT/2.5D-07/ IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 300 ZCRT = PCRT/DCRT/GKK/TCRT ZN = ZCRT-1.0D00 PC = PCRT CALL S01NBU(T,PSATF,DPSDT) P=PSATF PI = P/PC PIT = DPSDT/PC TC = TCRT X = T/TC X2 = X*X V = 1.0D00-X V1 = -1.0D00 VE = V**EG VE1 = -EG*VE/V EGXV = EGX/V IF(EGXV.LE.290.0D00) GO TO 11 XP1 = 0.0D00 XP = 0.0D00 GO TO 12 11 XP = DEXP(-EGXV) XP1 = -EGXV*XP/V 12 F = 1.0D00 + AV(1)*VE + AV(2)*V + AV(3)*XP F1 = AV(1)*VE1 - AV(2) + AV(3)*XP1 ZFX = F ZSM1 = ZN*PI*F/X2 Z = 1.0D00 + ZSM1 ZSAT = Z DZDT = (PI*(F1-2.0D00*F/X)/TC + F*PIT)*ZN/X2 DGASF = P/T/Z/GKK DDSDT = (DPSDT - P/T - P*DZDT/Z)/T/Z/GKK RETURN 300 DGASF = DCRT DDSDT = 1.0D+15 RETURN END C C *** DDSDT(L) SUBROUTINE S03NBU(T,DDSDT,DLIQF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AW(3) DATA EL / 0.35D00/ DATA DCRT,DTRP,TTRP,TCRT /3.90D00,12.65D00,134.86D00,425.16D00/ DATA AW / 0.802377995D00, -0.139053759D00, 0.057353024D00/ DATA DLT/2.5D-07/ IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 300 XN=TCRT-TTRP X=(TCRT-T)/XN X2 = X*X DXDT = -1.0D00/XN XE = X**EL V = XE - X V1 = EL*XE/X - 1.0D00 Y = AW(1) + AW(2)*X2 + AW(3)*X*X2 YNL = DTRP - DCRT Y1 = 2.0D00*AW(2)*X + 3.0D00*AW(3)*X2 DLIQF = DCRT + YNL*(X + V*Y) DDSDT = YNL*(1.0D00 + V*Y1 + V1*Y)*DXDT RETURN 300 DLIQF = DCRT DDSDT = 1.0D+15 RETURN END C C *** PVTF,DPDT,D2PDT2,DPDD SUBROUTINE S04NBU(T,D,M,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) C N-BUTANE EQNSTATE, PVTF = P,BAR. C NOTE, M=0 RETURNS DP/DT, D2P/DT2. M=1 RETURNS ALSO DP/DD. C P-PSAT = S*GK*(T-TSAT) + S*S*GK*TCRT*F(S,T), WHERE - C F(S,T) = B(S)*XBF(S,T) + E(S)*XEF(S,T), AND - C B(S) = B1 + B2*EXP(BE*S), E(S) = E1*(S-1)*(S-ER)*EXP(-GA*S**IX). C WHERE, R = DEN/DTRP, S = DEN/DCRT. IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON GK,GKK, B1,B2,B3,B4, E1,ER, IX COMMON/B1/AL,BE,GA,DE,EP, DCRT,TCRT,PCRT, DGAT,DTRP,TTRP,PTRP COMMON/B4/XB1,XB2, XC1,XC2, XE1,XE2, DXBDR,DXCDR,DXEDR COMMON/B6/ TSAT, THETA, PSAT COMMON/B13/ ZCRT COMMON/B14/ ZSAT,ZFX C CALL S05NBU R = D/DTRP S = D/DCRT SN = S-1.0D00 IF(ER) 2,3,3 2 SR = S - ER SR1 = 1.0D00 GO TO 4 3 SR = 1.0D00 SR1 = 0.0D00 4 S2 = S*S S3 = S*S2 SX = S**IX GK = DCRT*GKK TC = TCRT DSDR = DTRP/DCRT RG = S*GK GKT = GK*TC CALL S06NBU(D,TSATF,DTSDR) TS=TSATF TSAT=TS CALL S01NBU(TS,PSATF,DPSDT) PS=PSATF PSAT=PS CALL S07NBU(D,THETAF,DTHDR) THETA=THETAF CALL S08NBU(T,D,XBF) XB = XBF CALL S09NBU(T,D,XEF) XE = XEF 9 XPB = DEXP(BE*S) B = B1*S2 + B2*S2*XPB 10 XP = DEXP(-GA*SX) SM = SN*SR*S2 E = E1*SM*XP 12 F = B*XB + E*XE F1 = B*XB1 + E*XE1 F2 = B*XB2 + E*XE2 13 PVTF = PS + RG*(T-TS) + GKT*F FRT=F/S2 DFRTDT=F1/S2/TC 14 DPDT = RG + GK*F1 D2PDT2 = GK*F2/TC IF(M) 15,30,15 15 BD = (2.0D00*B1*S + B2*(BE*S2 + 2.0D00*S)*XPB)*DSDR 16 SM1 = SR*S2 + SN*SR1*S2 + SN*SR*2.0D00*S XP1 = -DBLE(IX)*GA*SX/S 17 ED = E1*(SM*XP1 + SM1)*XP*DSDR 20 F1 = B*DXBDR + BD*XB + E*DXEDR + ED*XE 26 DPDR = (DPSDT-RG)*DTSDR + (T-TS)*GK*DSDR + GKT*F1 27 DPDD = DPDR/DTRP 30 RETURN END C C *** PARAMETER SUBROUTINE S05NBU C N-BUTANE EQNSTATE JULY 25, 1978 AT 11.29. C NEW XEF, DGASF, EDELF, FOR LOW DENSITIES. C P - PSAT = S*GK*(T-TSAT) + S*S*GK*TCRT*F(S,T), C F(S,T) = B(S)*XBF(S,T) + E(S)*XEF(S,T) W = (1-TH/T), C XBF(S,T) = SQRT(X)*LN(T/TSAT), XEF(S,T) = PSI - PSISAT, WHERE - C PSI(S,T) = DE*EXP(EP*(1-X)) + (1-DE)*(1 - W + W*LN(W)). C B(S) = B1 + B2*EXP(BE*S), R = DEN/DTRP, S = DEN/DCRT. C E(S) = E1*(S-1)*EXP(-GA*S**IX). IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON GK,GKK, B1,B2,B3,B4, E1,ER, IX COMMON/B1/AL,BE,GA,DE,EP, DCRT,TCRT,PCRT, DGAT,DTRP,TTRP,PTRP COMMON/B13/ ZCRT COMMON/B99/ EZZ 17 WM = 58.1243D00 Q = 1.01325D00 QP = Q/14.69595D00 EPP = 1.85D00 18 TTRP=134.86D00 DTRP=12.65D00 TTRP1=TTRP-273.15D00 PTRP=F30NBU(TTRP1) 19 TCRT=425.16D00 DCRT=3.900D00 TCRT1=TCRT-273.15D00 PCRT=F30NBU(TCRT1) 20 GKK = 0.083145D00 GK = GKK*DCRT ZCRT = PCRT/DCRT/GKK/TCRT 21 IX=4 AL=1.0D00 BE=0.80D00 GA=0.30D00 DE=2.0D00/3.0D00 EP=3.0D00 ER=0.0D00 22 B1=0.35427006233D+00 B2=0.26628373954D+00 B4=0.0D00 B3=0.0D00 E1=0.42192906133D+00 23 DGAT = 1.0D00/(F54NBU(TTRP1)*WM) 24 WK = 100000.0D00/WM EZZ=22580.9D00 RETURN END C C *** TSATF SUBROUTINE S06NBU(DEN,TSATF,DTSDR) C ITERATE T TO MINIMIZE (DEN-DCALC) VIA DGASF(T), DLIQF(T). IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON/B1/AL,BE,GA,DE,EP, DCRT,TCRT,PCRT, DGAT,DTRP,TTRP,PTRP COMMON/B14/ ZSAT,ZFX DATA Q, FN / 2.0D00, 6.3890561D00 / DATA WM/58.1243D00/ C NOTE, FN = EXP(Q) - 1.0. CALL S05NBU D=DEN S=D/DCRT YN=TCRT/TTRP-1.0D00 IF(DEN-DCRT) 3,30,4 3 ST=DGAT/DCRT F=DLOG(S)/DLOG(ST)*((1.0D00-S)/(1.0D00-ST))**2 GO TO 5 4 ST=DTRP/DCRT U=((S-1.0D00)/(ST-1.0D00))**3 F=(DEXP(Q*U)-1.0D00)/FN 5 TT = TCRT/(1.0D00 + YN*F) DO 15 J=1,100 IF(DEN-DCRT) 7,30,8 7 CALL S02NBU(TT,DDSDT,ZSAT,ZFX,DGASF) DD = D - DGASF GO TO 9 8 CALL S03NBU(TT,DDSDT,DLIQF) DD = D - DLIQF 9 IF(DABS(DD/D).LT.1.0D-7) GO TO 16 10 DT = DD/DDSDT IF(DABS(DT/TT).LT.1.0D-7) GO TO 16 11 TT = TT + DT IF(TT) 12,12,13 12 TT = TTRP GO TO 15 13 IF(TT.LT.TCRT) GO TO 15 14 TT = TCRT - 0.10D00 15 CONTINUE 16 TSATF = TT DTSDR = DTRP/DDSDT RETURN 30 TSATF = TCRT DTSDR = 0.0D00 RETURN END C C *** THETAF SUBROUTINE S07NBU(DEN,THETAF,DTHDR) C THETA = TSAT*EXP(U(S)). C LET Q = (S-1)/(ST-1), WHERE ST = DTRP/DCRT, THEN - C IF S < 1, U = AL*Q**3, IF S > 1, U = -AL*Q**3, IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON/B1/AL,BE,GA,DE,EP, DCRT,TCRT,PCRT, DGAT,DTRP,TTRP,PTRP COMMON/B6/ TSAT, THETA, PSAT CALL S05NBU CALL S06NBU(DEN,TSATF,DTSDR) 1 S = DEN/DCRT DSDR = DTRP/DCRT C = DSDR-1.0D00 2 Q = (S-1.0D00)/C Q2 = Q*Q U = AL*Q*Q2 3 U1 = AL*3.0D00*Q2*DSDR/C IF(Q) 5,9,4 4 U = -U U1 = -U1 5 XP = DEXP(U) THETAF = TSAT*XP 6 DTHDR = (TSAT*U1 + DTSDR)*XP RETURN 9 THETAF = TCRT DTHDR = 0.0D00 RETURN END C C *** XBF SUBROUTINE S08NBU(T,D,XBF) C XBF = SQRT(T/TC)*LN(T/TS) = Q(T)*Z(R,T), IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON/B1/AL,BE,GA,DE,EP, DCRT,TCRT,PCRT, DGAT,DTRP,TTRP,PTRP COMMON/B4/XB1,XB2, XC1,XC2, XE1,XE2, DXBDR,DXCDR,DXEDR COMMON/B6/ TSAT, THETA, PSAT CALL S05NBU CALL S06NBU(D,TSATF,DTSDR) 1 TC = TCRT TS = TSAT X = T/TC 2 U = T/TS U1X = TC/TS U1R = -U*DTSDR/TS 3 Z = DLOG(U) Z1R=U1R/U Z1X=U1X/U Z2X=-Z1X*Z1X 4 Q = DSQRT(X) Q1 = 0.5D00/Q Q2 = -Q1/2.0D00/X 5 XBF = Q*Z DXBDR = Q*Z1R XB1 = Q*Z1X + Q1*Z 6 XB2 = Q*Z2X + Q1*2.0D00*Z1X + Q2*Z RETURN END C C *** XEF SUBROUTINE S09NBU(T,D,XEF) C XEF = PSI - PSISAT, PSI = A*F(T) + B*H(R,T), W = (1-TH/H), AND - C F(T) = EXP(C*(1-X)), H(R,T) = (1 - W + W*LN(W)). IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON/B1/AL,BE,GA,DE,EP, DCRT,TCRT,PCRT, DGAT,DTRP,TTRP,PTRP COMMON/B4/XB1,XB2, XC1,XC2, XE1,XE2, DXBDR,DXCDR,DXEDR COMMON/B6/ TSAT, THETA, PSAT CALL S05NBU CALL S06NBU(D,TSATF,DTSDR) CALL S07NBU(D,THETAF,DTHDR) 1 A=DE B=1.0D00-A C=EP TC=TCRT TS=TSAT TH=THETA 2 X = T/TC XS = TS/TC XS1 = DTSDR/TC 3 W = 1.0D00 - TH/T IF(W) 30,30,4 4 F = DEXP(C*(1.0D00-X)) F1 = -C*F F2 = -C*F1 5 W1R = -DTHDR/T W1X = TH/T/X W2X = -2.0D00*W1X/X 6 G = DLOG(W) H = W*G - W + 1.0D00 H1R = G*W1R 7 H1X = G*W1X H2X = G*W2X + W1X*W1X/W 10 P = A*F + B*H P1R = B*H1R 11 XE1 = A*F1 + B*H1X XE2 = A*F2 + B*H2X 15 WS = 1.0D00 - TH/TS IF(WS) 16,16,17 16 HS = 1.0D00 FS = 1.0D00 HS1 = 0.0D00 FS1 = 0.0D00 GO TO 21 17 WS1 = (TH*DTSDR/TS - DTHDR)/TS GS = DLOG(WS) 18 HS = WS*GS - WS + 1.0D00 HS1 = GS*WS1 20 FS = DEXP(C*(1.0D00-XS)) FS1 = -C*XS1*FS 21 PS = A*FS + B*HS PS1 = A*FS1 + B*HS1 25 XEF = P - PS DXEDR = P1R - PS1 RETURN 30 XEF = 0.0D00 XE1 = 0.0D00 XE2 = 0.0D00 DXEDR = 0.0D00 RETURN END C C *** EDELF SUBROUTINE S11NBU(L,N,T,DA,DB,EDELF,DELS,DELCV) C SPECIAL REVISION FOR VERY LOW DENSITIES. C GET CHANGE OF E, S, CV WITH DENSITY ALONG ISOTHERMS. C GET EDELF, DELS, DELCV FROM DA TO DB ON ISOTHERM T. IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER N COMMON/B1/AL,BE,GA,DE,EP, DCRT,TCRT,PCRT, DGAT,DTRP,TTRP,PTRP COMMON/B13/ ZCRT COMMON/B14/ ZSAT,ZFX DATA G / 0.083145D00 / CALL S05NBU ZK = 1.0D00 - 1.0D00/ZCRT RK = G*TCRT/DCRT CV = 0.0D00 E = 0.0D00 S = 0.0D00 DX = (DB-DA)/DBLE(N) IF(DX.EQ.0.0D00) GO TO 30 DO 15 J=1,N DN = DA + (DBLE(J)-0.5D00)*DX DXN = DX/DN/DN CALL S04NBU(T,DN,0,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) P = PVTF CV = CV - D2PDT2*DXN IF(DN.GE.DCRT) GO TO 9 E = E + (ZK*ZSAT*ZFX + FRT - T*DFRTDT)*RK*DX GO TO 10 9 E = E + (P - T*DPDT)*DXN 10 IF(L.NE.0) GO TO 12 S = S - DPDT*DXN GO TO 15 12 S = S + (G - DPDT/DN)*DX/DN 15 CONTINUE EDELF = 100.0D00*E DELS = 100.0D00*S DELCV = 100.0D00*T*CV RETURN 30 EDELF = 0.0D00 DELS = 0.0D00 DELCV = 0.0D00 RETURN END C C *** CSATXF SUBROUTINE S12NBU(T,CSATXF) C N-BUTANE, VIA SSATFIT AND SSATF(T), JULY, 1978. C CSATF(T) = X*DSSATF(X)/DX, X = T/TCRT. C FOR SSAT = A + B*(1-X)**ES + C*LN(X) + D*X + E*X2 + F*X3, C CSAT = -ES*B*X/(1-X)**(1-ES) + C + D*X + 2*E*X2 + 3*F*X3. IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA ES,TCRT,B,C/0.50D00,425.16D00,-35.1425285D00,92.4274005D00/ DATA D,E,F/62.3909664D00,-51.4000625D00,31.1204971D00/ DATA DLT/2.5D-07/ IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 4 GO TO 5 4 CSATXF = 0.0D00 RETURN 5 X = T/TCRT X2 = X*X XE = (1.0D00-X)**(1.0D00-ES) CSATXF = -ES*B*X/XE + C + D*X + 2.0D00*E*X2 + 3.0D00*F*X*X2 RETURN END C C *** CVSATF SUBROUTINE S13NBU(T,CVSATF) C N-BUTANE CV ON SATLIQ. BOUNDARY. AUG. 7, 1978 AT 9.32. C FOR USE FROM T = 355 UP TO TCRT. C CVS = A + B*X + C*X2*LN(1 + EC/(1-X)), X = T/TCRT. IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA EC, TCRT / 53.0D00, 425.16D00/ DATA A, B, C / 68.86999D00, 18.92882D00, 6.855379D00 / X = T/TCRT X2 = X*X XL = DLOG(1.0D00+EC/(1.0D00-X)) CVSATF = A + B*X + C*X2*XL RETURN END C C *** IDEAL SUBROUTINE S14NBU(TI,EZ,SZ,HZ,CVZ,CPZ) C N-BUTANE, VIA DATA OF CHEN ET AL (1975). C CPZ/R = 4 + (A1 + A2/X + A3/X2 + . . )*EXP(-E/X), X = T/100. IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(5) DATA R, SI, HI, E / 8.31450D00, 37.3495D00, 7.7980D00, 2.37D00 / DATA A / 41.1109726D00,-139.304011D00, 257.297067D00, 1 -170.730596D00, 40.0321709D00/ NK = 5 XI = TI/100.0D00 XP = DEXP(-E/XI) CP = 4.0D00 DO 3 K=1,NK 3 CP = CP + A(K)*XP*XI**(1-K) C NUMERICAL INTEGRATION FOR HZ/R, SZ/R - S = 0.0D00 H = 0.0D00 N = IDINT(DABS(TI-300.0D00))/4 + 4 DX = (XI-3.0D00)/DBLE(N) DO 10 J=1,N X = 3.0D00 + (DBLE(J)-0.5D00)*DX XP = DEXP(-E/X) CPX = 4.0D00 DO 8 K=1,NK 8 CPX = CPX + A(K)*XP*X**(1-K) H = H + CPX*DX S = S + CPX*DX/X 10 CONTINUE H = (HI*3.0D00 + H)/XI S = SI + S C CONVERT TO JOULES, MOLES, KELVINS. HZ = R*TI*H EZ = HZ - R*TI SZ = R*S CPZ = R*CP CVZ = CPZ - R RETURN END C C *** QVAPXF SUBROUTINE S18NBU(T,QVAPXF) C N-BUTANE, ADJUSTED JULY 27, 1978, AT 06.58, R.D.G. C FOR 85 WEIGHTED DATA (INCL. CLAPEYRON), RMS = 0.39 PCT. C QVAP/1000 = A*X + (XE-X)*(B + C*X/XE + D*X), WHERE - C X = (TC-T)/(TC-TT), XE = X**E. IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA E,TTRP,TCRT,XN/0.30D00,134.86D00,425.16D00,290.30D00/ DATA A,B,C,D/28.725885D00,18.498277D00,40.071066D00,-37.359808D00/ DATA DLT/2.5D-07/ IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 4 GO TO 5 4 QVAPXF = 0.0D00 RETURN 5 X = (TCRT-T)/XN XE = X**E 6 Q = A*X + (XE-X)*(B + C*X/XE + D*X) 7 QVAPXF = Q*1000.0D00 RETURN END C C *** CVTD SPECIFIC HEAT CAPACITY OF SATURATED LIQUID SUBROUTINE S19NBU(T,CVL) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /134.86D00,425.16D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 300 TT=T-273.15D00 ALO=F53NBU(TT) DL=1.0D00/(ALO*WM) CALL S03NBU(T,DDSDT,DLIQF) DDLDT=DDSDT CALL S12NBU(T,CSATXF) CSAT = CSATXF CALL S04NBU(T,DL,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) IF(T.LT.355.0D00) GO TO 22 CALL S13NBU(T,CVSATF) CVL = CVSATF RETURN 22 CVL = CSAT + 100.0D00*T*DPDT*DDLDT/DL/DL RETURN 300 CVL=+1.0E+20 RETURN END C C******************************************************************** C* ********************************** * C* * SUBROUTINE FOR ERROR MESSAGE * * C* ********************************** * C******************************************************************** C C *** LEVEL 1 ERROR MESSAGE *** SUBROUTINE S97NBU(FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** NO CONVERGENCE AT '//FUN//' FOR NORMAL BUTANE ****' WRITE(6,*) MSG END IF RETURN END C *** LEVEL 2 ERROR MESSAGE *** SUBROUTINE S98NBU(IPT,P,T,N1,N2,FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,N1*1,N2*1 IF(MESS.NE.0) THEN IF (IPT.EQ.1) THEN C --- FUN(P) TYPE WRITE(6,6010) FUN,P 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR NORMAL BUTANE', & ' WHEN P =',1PE14.7,' ****') C --- FUN(T) TYPE ELSE IF (IPT.EQ.2) THEN WRITE(6,6020) FUN,T 6020 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR NORMAL BUTANE', & ' WHEN T =',1PE14.7,' ****') C --- FUN(P,T) TYPE ELSE WRITE(6,6030) FUN,N1,P,N2,T 6030 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR NORMAL BUTANE', &' WHEN ',A1,' =',1PE14.7,' AND ',A1,' =',1PE14.7,' ****') END IF END IF RETURN END C *** LEVEL 3 ERROR MESSAGE *** SUBROUTINE S99NBU(FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** FUNCTION '//FUN//' UNAVAILABLE FOR NORMAL BUTANE ****' WRITE(6,100) MSG 100 FORMAT(1H ,5X,A) END IF RETURN END REAL FUNCTION T90(T) * Conversion of temperature scal from IPTS-68 to ITS-90 * Range -200C<=T68<=630C anf T68>=1064 REAL T68,T0K REAL*8 CA(8) INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA CA/-0.14542, -0.26722, 1.06471, 1.131286, -4.25835, + -1.59924, 7.29176, -3.52573/ IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF T68=T-T0K * Check of argument range IF((-200.0.LE.T68).AND.(T68.LE.630.0)) THEN RT68=T68/630.0 TEMP=T68+RT68*(CA(1)+RT68*(CA(2)+RT68*(CA(3)+RT68*(CA(4) + +RT68*(CA(5)+RT68*(CA(6)+RT68*(CA(7)+RT68*CA(8)))))))) ELSE IF((1064.0.LE.T68).AND.(T68.LE.3000.0)) THEN TEMP=T68-0.25*(T68+273.15)*(T68+273.15)/1337.33/1337.33 ELSE IF(MESS.NE.0) WRITE(6,6020) T 6020 FORMAT(1H ,5X,'**** OUT OF RANGE AT T90', & ' WHEN T68 =',1PE14.7,' ****') T90=-1.0E+20 RETURN END IF T90=TEMP+T0K RETURN END REAL FUNCTION T68(T) * Conversion of temperature scal from ITS-90 to IPTS-68 * Range -200C<=T68<=630C anf T68>=1064 T1=T90(T) T2=T ITER=0 DT=T-T1 1000 CONTINUE ITER=ITER+1 IF(ITER.GE.10000) THEN WRITE(6,*) ' ITERATION EXCEEDED MAXIMUM ' T68=-1.0E+10 RETURN END IF T2=T2+DT T1=T90(T2) DT=T-T1 IF(ABS(DT).GE.1.0E-4) GOTO 1000 T68=T2 RETURN END * Subroutine Program Specifying KPA and MESS * MS-FORTRAN and MS-C Mixed Langage Programing * SUBROUTINE KPAMES(KPAC,MESSC) COMMON/UNIT/KPA,MESS INTEGER KPAC INTEGER MESSC KPA=KPAC MESS=MESSC RETURN END