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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(FUN) ALAPT=-1.0E+30 RETURN END C------------------------------------------------- F4 = ALHP REAL FUNCTION ALHP(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F4IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHP'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F4IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F5IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHT'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F5IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(FUN) AMUTDD=-1.0E+30 RETURN END C------------------------------------------------- F16 = CPPD REAL FUNCTION CPPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F16IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F16IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F17IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPDD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F17IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F18IBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPT'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) TI=G99IBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F18IBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F19IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPTD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F19IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F20IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPTDD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F20IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F21IBU COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FLUID/'ISOBUTANE'/, 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 = F21IBU(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 S99IBU(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 ISOBUTANE 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 F23IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F23IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F24IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPDD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F24IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F25IBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPT'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) TI=G99IBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F25IBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(FUN) HPX=-1.0E+30 RETURN END C------------------------------------------------- F27 = HTD REAL FUNCTION HTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F27IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F27IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F28IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTDD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F28IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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='ISOBUTANE' WHEN A='S' C B='(CH3)2CHCH3' 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='ISOBUTANE' ELSE IF (A.EQ.'C') THEN IDENTF='(CH3)2CHCH3' ELSE IF (A.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT IDENTF FOR ISOBUTANE 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 F30IBU,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 = F30IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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 S99IBU(FUN) SIGT=-1.0E+30 RETURN END C------------------------------------------------- F33 = SPD REAL FUNCTION SPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F33IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F33IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F34IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPDD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F34IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F35IBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPT'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) TI=G99IBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F35IBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(FUN) SPX=-1.0E+30 RETURN END C------------------------------------------------- F37 = STD REAL FUNCTION STD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F37IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F37IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F38IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STDD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F38IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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 F40IBU,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 = F40IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F41IBU COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FLUID/'ISOBUTANE'/, 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 = F41IBU(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 F42IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F42IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F43IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPDD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F43IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F44IBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPT'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) TI=G99IBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F44IBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(FUN) UPX=-1.0E+30 RETURN END C------------------------------------------------- F46 = UTD REAL FUNCTION UTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F46IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F46IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F47IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTDD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F47IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(FUN) UTX=-1.0E+30 RETURN END C------------------------------------------------- F49 = VPD REAL FUNCTION VPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F49IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F49IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F50IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPDD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F50IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F51IBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPT'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) TI=G99IBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F51IBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(FUN) VPX=-1.0E+30 RETURN END C------------------------------------------------- F53 = VTD REAL FUNCTION VTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F53IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F53IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F54IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTDD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F54IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 F68IBU,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 = F68IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F69IBU,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 = F69IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(FUN) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F76 = CVPDD REAL FUNCTION CVPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F76IBU,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CVPDD'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F76IBU(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F77IBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CVPT'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) TI=G99IBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F77IBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 F78IBU,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CVTDD'/ C--- SET OF UNIT --- TI=G99IBU(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F78IBU(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 F83IBU,DBP,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'WPT'/ C--- SET OF UNIT --- PI=G98IBU(KPA,P) TI=G99IBU(KPA,T) DBP=DBLE(PI) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F83IBU(DBP,DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97IBU(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(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 S99IBU(FUN) TSBP=-1.0E+30 RETURN END C C#################################################################### C C******************************************************************** C* ********************************** * C* * A PROGRAM PACKAGE OF ISOBUTANE * * 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 F4IBU(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 HL=F23IBU(P) HV=F24IBU(P) IF(HL.EQ.-1.0E+20.OR.HV.EQ.-1.0E+20) GO TO 900 F4IBU=HV-HL RETURN 600 F4IBU=-1.0E+20 RETURN 900 F4IBU=-1.0E+20 RETURN END C *** ALHT(T) LATENT HEAT OF VAPORIZATION DOUBLE PRECISION FUNCTION F5IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 HL=F27IBU(T) HV=F28IBU(T) IF(HL.EQ.-1.0E+20.OR.HV.EQ.-1.0E+20) GO TO 900 F5IBU=HV-HL RETURN 600 F5IBU=-1.0E+20 RETURN 900 F5IBU=-1.0E+20 RETURN END C *** CPPD(P) SPECIFIC HEAT CAPACITY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F16IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ DATA TCRT /408.00D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F49IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40IBU(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 S03IBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S12IBU(TM,CSATXF) CSAT = CSATXF CALL S04IBU(TM,DL,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) IF(TM.LE.340.0D00) GO TO 22 CALL S13IBU(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 F16IBU=CP*(1.0D03/WM) RETURN 300 F16IBU=+1.0E+20 RETURN 600 F16IBU=-1.0E+20 RETURN 900 F16IBU=-1.0E+20 RETURN END C *** CPPDD(P) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F17IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ DATA TCRT /408.00D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F50IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40IBU(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 S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV CALL S04IBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CPG = CVG + 100.0D00*TM/DPDD*(DPDT/DB)**2 F17IBU=CPG*(1.0D03/WM) RETURN 300 F17IBU=+1.0E+20 RETURN 600 F17IBU=-1.0E+20 RETURN 900 F17IBU=-1.0E+20 RETURN END C *** CPPT(P,T) SPECIFIC HEAT CAPACITY DOUBLE PRECISION FUNCTION F18IBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA TTRP,TCRT /113.55D00,408.00D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69IBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.1.8893D-07.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51IBU(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=F40IBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,30,30 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,30,30 END IF C 2 CALL S03IBU(TM,DDSDT,DLIQF) DL=DLIQF DDLDT=DDSDT IF(TM.LE.340.0D00) GO TO 9 8 CALL S13IBU(TM,CVSATF) CVS = CVSATF GO TO 10 9 CALL S04IBU(TM,DL,0,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CALL S12IBU(TM,CSATXF) CVS = CSATXF + 100.0D00*TM*DPDT*DDLDT/DL/DL 10 DX = DB - DL IF(DX) 20,20,11 11 N = DX*10 + 5 CALL S11IBU(0,N,TM,DL,DB,EDELF,DELS,DELCV) CV = CVS + DELCV 13 CALL S04IBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CP = CV + 100.0D00*TM/DPDD*(DPDT/DB)**2 GO TO 100 20 CV=CVS CP = CV + 100.0D00*TM/DPDD*(DPDT/DL)**2 GO TO 100 C 30 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CV = CVZ + DELCV CALL S04IBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CP = CV + 100.0D00*TM/DPDD*(DPDT/DB)**2 100 F18IBU=CP*(1.0D03/WM) RETURN 300 F18IBU=+1.0E+20 RETURN 600 F18IBU=-1.0E+20 RETURN 900 F18IBU=-1.0E+20 RETURN END C *** CPTD(T) SPECIFIC HEAT CAPACITY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F19IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ 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=F53IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) CALL S03IBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S12IBU(TM,CSATXF) CSAT = CSATXF CALL S04IBU(TM,DL,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) IF(TM.LE.340.0D00) GO TO 22 CALL S13IBU(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 F19IBU=CP*(1.0D03/WM) RETURN 300 F19IBU=+1.0E+20 RETURN 600 F19IBU=-1.0E+20 RETURN 900 F19IBU=-1.0E+20 RETURN END C *** CPTDD(T) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F20IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ 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=F54IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV CALL S04IBU(TM,DB,1,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CPG = CVG + 100.0D00*TM/DPDD*(DPDT/DB)**2 F20IBU=CPG*(1.0D03/WM) RETURN 300 F20IBU=+1.0E+20 RETURN 600 F20IBU=-1.0E+20 RETURN 900 F20IBU=-1.0E+20 RETURN END C *** CRP(A) QUANTITIES AT THE CRITICAL POINT DOUBLE PRECISION FUNCTION F21IBU(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 F21IBU=752.5D03 RETURN 10 IF(A.NE.B(2)) GO TO 20 F21IBU=36.5489D00 RETURN 20 IF(A.NE.B(3)) GO TO 30 F21IBU=4.791D03 RETURN 30 IF(A.NE.B(4)) GO TO 40 F21IBU=134.85D00 RETURN 40 IF(A.NE.B(5)) GO TO 900 F21IBU=4.46D-03 RETURN 900 F21IBU=-1.0E+20 RETURN END C *** HPD(P) SPECIFIC ENTHALPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F23IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ 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=F49IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 CALL S03IBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18IBU(TM,QVAPXF) QV=QVAPXF HG=F24IBU(P) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV F23IBU=H*(1.0D03/WM) RETURN 300 CONTINUE ALO=F49IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/ALO PS=P UL=F42IBU(P) IF(UL.EQ.-1.0E+20) GO TO 900 HL = UL + 1.0D05*PS/DL F23IBU= HL RETURN 600 F23IBU=-1.0E+20 RETURN 900 F23IBU=-1.0E+20 RETURN END C *** HPDD(P) SPECIFIC ENTHALPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F24IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ DATA WM/58.1243D00/ DATA EZZ/23838.616217D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 PS = P ALO=F50IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF HG = EG + 100.0D00*PS/DB F24IBU=HG*(1.0D03/WM) RETURN 600 F24IBU=-1.0E+20 RETURN 900 F24IBU=-1.0E+20 RETURN END C *** HPT(P,T) SPECIFIC ENTHALPY DOUBLE PRECISION FUNCTION F25IBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA TTRP,TCRT /113.55D00,408.00D00/ DATA WM/58.1243D00/ DATA EZZ/23838.616D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69IBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.1.8893D-07.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51IBU(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=F40IBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,30,30 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,30,30 END IF C 2 PS=F30IBU(T) CALL S03IBU(TM,DDSDT,DLIQF) DL=DLIQF CALL S19IBU(TM,HSATF) HS=HSATF ES = HS - 100.0D00*PS/DL 10 DX = DB - DL IF(DX) 20,20,11 11 N = DX*10 + 5 CALL S11IBU(0,N,TM,DL,DB,EDELF,DELS,DELCV) E = ES + EDELF H = E + 100.0D00*P/DB GO TO 100 20 H=HS GO TO 100 C 30 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) E = EZZ + EZ + EDELF H = E + 100.0D00*P/DB 100 F25IBU=H*(1.0D03/WM) RETURN 600 F25IBU=-1.0E+20 RETURN 900 F25IBU=-1.0E+20 RETURN END C *** HTD(T) SPECIFIC ENTHALPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F27IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ 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=F53IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) CALL S03IBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18IBU(TM,QVAPXF) QV=QVAPXF HG=F28IBU(T) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV F27IBU=H*(1.0D03/WM) RETURN 300 CONTINUE ALO=F53IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/ALO PS=F30IBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 UL=F46IBU(T) IF(UL.EQ.-1.0E+20) GO TO 900 HL = UL + 1.0D05*PS/DL F27IBU= HL RETURN 600 F27IBU=-1.0E+20 RETURN 900 F27IBU=-1.0E+20 RETURN END C *** HTDD(T) SPECIFIC ENTHALPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F28IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ DATA WM/58.1243D00/ DATA EZZ/23838.616217D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 ALO=F54IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) PS=F30IBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF HG = EG + 100.0D00*PS/DB F28IBU=HG*(1.0D03/WM) RETURN 600 F28IBU=-1.0E+20 RETURN 900 F28IBU=-1.0E+20 RETURN END C *** PST(T) SATURATION PRESSURE DOUBLE PRECISION FUNCTION F30IBU(T) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA EPP,TCRT,A,B/1.95D00,408.0D00,13.80835297D00,9.37269200D00/ DATA TTRP/113.55D000/ DATA PCRT/36.548852487D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ DATA C,D,E,F /-70.54663008D00, 112.75833458D00,-52.42140768D00, 1 47.81122198D00/ 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) F30IBU=PSATF RETURN 300 F30IBU=PCRT RETURN 600 F30IBU=-1.0E+20 RETURN END C *** SPD(P) SPECIFIC ENTROPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F33IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ DATA WM/58.1243D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F49IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 CALL S03IBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18IBU(TM,QVAPXF) QV=QVAPXF SG=F34IBU(P) IF(SG.EQ.-1.0E+20) GO TO 900 S=SG*WM/1.0D03-QV/TM F33IBU=S*(1.0D03/WM) RETURN 600 F33IBU=-1.0E+20 RETURN 900 F33IBU=-1.0E+20 RETURN END C *** SPDD(P) SPECIFIC ENTROPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F34IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ 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=F50IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) DNG = DB T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) SG = SZ + DELS - 100.0D00*G*DLOG(G*TM*DB/Q) F34IBU=SG*(1.0D03/WM) RETURN 600 F34IBU=-1.0E+20 RETURN 900 F34IBU=-1.0E+20 RETURN END C *** SPT(P,T) SPECIFIC ENTROPY DOUBLE PRECISION FUNCTION F35IBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA TTRP,TCRT /113.55D00,408.00D00/ DATA WM/58.1243D00/ DATA Q,G/1.01325D00,0.083145D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69IBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.1.8893D-07.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51IBU(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=F40IBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,30,30 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,30,30 END IF C 2 CALL S03IBU(TM,DDSDT,DLIQF) DL=DLIQF CALL S20IBU(TM,SSATF) SS=SSATF 10 DX = DB - DL IF(DX) 20,20,11 11 N = DX*10 + 5 CALL S11IBU(0,N,TM,DL,DB,EDELF,DELS,DELCV) S = SS + DELS GO TO 100 20 S=SS GO TO 100 C 30 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) S = SZ + DELS - 100.0D00*G*DLOG(G*TM*DB/Q) 100 F35IBU=S*(1.0D03/WM) RETURN 600 F35IBU=-1.0E+20 RETURN 900 F35IBU=-1.0E+20 RETURN END C *** STD(T) SPECIFIC ENTROPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F37IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ DATA WM/58.1243D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 ALO=F53IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) CALL S03IBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18IBU(TM,QVAPXF) QV=QVAPXF SG=F38IBU(T) IF(SG.EQ.-1.0E+20) GO TO 900 S=SG*WM/1.0D03-QV/TM F37IBU=S*(1.0D03/WM) RETURN 600 F37IBU=-1.0E+20 RETURN 900 F37IBU=-1.0E+20 RETURN END C *** STDD(T) SPECIFIC ENTROPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F38IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ 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=F54IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) PS=F30IBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) SG = SZ + DELS - 100.0D00*G*DLOG(G*TM*DB/Q) F38IBU=SG*(1.0D03/WM) RETURN 600 F38IBU=-1.0E+20 RETURN 900 F38IBU=-1.0E+20 RETURN END C *** TSP(P) SATURATION TEMPERATURE DOUBLE PRECISION FUNCTION F40IBU(P) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ DATA TCRT/408.00D00/ 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=F30IBU(T1) IF(DPP.EQ.-1.0E+20) GO TO 900 DP = P - DPP ADP = DABS (DP) CALL S01IBU(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 F40IBU=FINDTS-273.15D00 RETURN 300 F40IBU=TCRT-273.15D00 RETURN 600 F40IBU=-1.0E+20 RETURN 900 F40IBU=-1.0E+20 RETURN END C *** TRPL(A) QUANTITIES AT THE TRIPLE POINT DOUBLE PRECISION FUNCTION F41IBU(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 F41IBU=1.8893D-07 RETURN 10 IF(A.NE.B(2)) GO TO 900 F41IBU=-159.60D00 RETURN 900 F41IBU=-1.0E+20 RETURN END C *** UPD(P) SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F42IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ 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=F49IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 PS=P TM=T+273.15D00 CALL S03IBU(TM,DDSDT,DLIQF) DDLDT=DDSDT CALL S18IBU(TM,QVAPXF) QV=QVAPXF HG=F24IBU(P) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV E = H - 100.0D00*PS/DL F42IBU=E*(1.0D03/WM) RETURN 300 F42IBU= 0.0D00 RETURN 600 F42IBU=-1.0E+20 RETURN 900 F42IBU=-1.0E+20 RETURN END C *** UPDD(P) SPECIFIC INTERNAL ENERGY OF SATURATED VAPPOR DOUBLE PRECISION FUNCTION F43IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ DATA WM/58.1243D00/ DATA EZZ/23838.616217D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F50IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 TM=T+273.15D00 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF F43IBU=EG*(1.0D03/WM) RETURN 600 F43IBU=-1.0E+20 RETURN 900 F43IBU=-1.0E+20 RETURN END C *** UPT(P,T) SPECIFIC INTERNAL ENERGY DOUBLE PRECISION FUNCTION F44IBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA TTRP,TCRT /113.55D00,408.00D00/ DATA WM/58.1243D00/ DATA EZZ/23838.616D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69IBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.1.8893D-07.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51IBU(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=F40IBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,30,30 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,30,30 END IF C 2 PS=F30IBU(T) CALL S03IBU(TM,DDSDT,DLIQF) DL=DLIQF CALL S19IBU(TM,HSATF) HS=HSATF ES = HS - 100.0D00*PS/DL 10 DX = DB - DL IF(DX) 20,20,11 11 N = DX*10 + 5 CALL S11IBU(0,N,TM,DL,DB,EDELF,DELS,DELCV) E = ES + EDELF GO TO 100 20 E=ES GO TO 100 C 30 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) E = EZZ + EZ + EDELF 100 F44IBU=E*(1.0D03/WM) RETURN 600 F44IBU=-1.0E+20 RETURN 900 F44IBU=-1.0E+20 RETURN END C *** UTD(T) SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F46IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ 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=F53IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) PS=F30IBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 CALL S18IBU(TM,QVAPXF) QV=QVAPXF HG=F28IBU(T) IF(HG.EQ.-1.0E+20) GO TO 900 H=HG*WM/1.0D03-QV E = H - 100.0D00*PS/DL F46IBU=E*(1.0D03/WM) RETURN 300 F46IBU= 0.0D00 RETURN 600 F46IBU=-1.0E+20 RETURN 900 F46IBU=-1.0E+20 RETURN END C *** UTDD(T) SPECIFIC INTERNAL ENERGY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F47IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ DATA WM/58.1243D00/ DATA EZZ/23838.616217D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 ALO=F54IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) PS=F30IBU(T) IF(PS.EQ.-1.0E+20) GO TO 900 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) EG = EZZ + EZ + EDELF F47IBU=EG*(1.0D03/WM) RETURN 600 F47IBU=-1.0E+20 RETURN 900 F47IBU=-1.0E+20 RETURN END C *** VPD(P) SPECIFIC VOLUME OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F49IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 F49IBU=F53IBU(T) RETURN 600 F49IBU=-1.0E+20 RETURN 900 F49IBU=-1.0E+20 RETURN END C *** VPDD(P) SPECIFIC VOLUME OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F50IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40IBU(P) IF(T.EQ.-1.0E+20) GO TO 900 F50IBU=F54IBU(T) RETURN 600 F50IBU=-1.0E+20 RETURN 900 F50IBU=-1.0E+20 RETURN END C *** VPT(P,T) SPECIFIC VOLUME DOUBLE PRECISION FUNCTION F51IBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) REAL TTT,TTP,PP,TTM,TTCRT,PPS,PPC DATA DCRT,DTRP,TTRP,TCRT /3.86D00,12.755D00,113.55D00,408.00D00/ DATA WM /58.1243D00/ DATA DM,GKK /13.5,0.083145/ DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA TMAX,PMAX /426.851D00,700.001D00/ DATA DLT/2.5D-06/ TP=F69IBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.1.8893D-07.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=F54IBU(T) IF(ALG.EQ.-1.0E+20) GO TO 900 DG=1.0D00/(ALG*WM) ALOL=F53IBU(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALOL*WM) PS=F30IBU(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 S04IBU(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 S04IBU(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 F51IBU=1.D00/(D*WM*1.0D-3/1.0D-3) RETURN 32 F51IBU=1.D00/(DG*WM*1.0D-3/1.0D-3) RETURN 33 F51IBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 34 F51IBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F51IBU=-1.0E+20 RETURN 900 F51IBU=-1.0E+20 RETURN 950 F51IBU=-1.0E+10 RETURN END C *** VTD(T) SPECIFIC VOLUME OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F53IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DIMENSION AW(3) DATA EL / 0.35D00/ DATA DCRT,DTRP,TTRP,TCRT /3.86D00,12.755D00,113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ DATA AW / 0.786913448D00, -0.142753535D00, 0.057698164D00/ 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) F53IBU=1.D00/(DLIQF*WM*1.0D-3/1.0D-3) RETURN 300 F53IBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F53IBU=-1.0E+20 RETURN END C *** VTDD(T) SPECIFIC VOLUME OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F54IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DIMENSION AV(3) DATA DCRT,TTRP,TCRT/3.86D00,113.55D00,408.00D00/ DATA PCRT/36.548852487D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ DATA EG, EGX, GKK / 0.35D00, 3.60D00, 0.083145D00 / DATA AV / -0.764051836D00, 0.650501182D00, 30.75066326D00/ 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 = F30IBU(T) IF(P.EQ.-1.0E+20) GO TO 900 CALL S01IBU(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*(1.0D00-1.0D00/V) IF(EGXV.GE.-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 F54IBU=1.D00/(DGASF*WM*1.0D-3/1.0D-3) RETURN 300 F54IBU=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F54IBU=-1.0E+20 RETURN 900 F54IBU=-1.0E+20 RETURN END C *** PMLT(T) PRESSURE ON THE MELTING LINE DOUBLE PRECISION FUNCTION F68IBU(T) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,TTRP/1.8893D-07,113.55D00/ C TC -- TMLP(700 bar) DATA TC/133.107D00/,TL/113.55D00/ DATA TCX/133.1071D00/,TLX/113.549D00/ DATA A, E / 430.0D00, 6.08D00 / DATA DLT/1.0D-07/ 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) F68IBU=PMELTF RETURN 600 F68IBU=-1.0E+20 RETURN END C *** TMLP(P) TEMPERATURE ON THE MELTING LINE DOUBLE PRECISION FUNCTION F69IBU(P) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,TTRP/1.8893D-07,113.55D00/ DATA PTRPX/1.88929D-07/ DATA A, E / 430.0D00, 6.080D00 / IF(P.LT.PTRPX.OR.P.GT.700.001D00) GO TO 600 X = (P-PTRP)/A + 1.0D00 FINDTM = TTRP*X**(1.0D00/E) F69IBU=FINDTM-273.15D00 RETURN 600 F69IBU=-1.0E+20 RETURN END C *** CVPDD(P) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F76IBU(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA PTRPX,PCRTX/1.88929D-07,36.54891D00/ DATA TCRT /408.00D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 ALO=F50IBU(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) T=F40IBU(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 S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,DA,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV F76IBU=CVG*(1.0D03/WM) RETURN 300 F76IBU=+1.0E+20 RETURN 600 F76IBU=-1.0E+20 RETURN 900 F76IBU=-1.0E+20 RETURN END C *** CVPT(P,T) SPECIFIC HEAT CAPACITY DOUBLE PRECISION FUNCTION F77IBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA TTRP,TCRT /113.55D00,408.00D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69IBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.1.8893D-07.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51IBU(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=F40IBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,30,30 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,30,30 END IF C 2 CALL S03IBU(TM,DDSDT,DLIQF) DL=DLIQF DDLDT=DDSDT IF(TM.LE.340.0D00) GO TO 9 8 CALL S13IBU(TM,CVSATF) CVS = CVSATF GO TO 10 9 CALL S04IBU(TM,DL,0,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CALL S12IBU(TM,CSATXF) CVS = CSATXF + 100.0D00*TM*DPDT*DDLDT/DL/DL 10 DX = DB - DL IF(DX) 20,20,11 11 N = DX*10 + 5 CALL S11IBU(0,N,TM,DL,DB,EDELF,DELS,DELCV) CV = CVS + DELCV GO TO 100 20 CV=CVS GO TO 100 C 30 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CV = CVZ + DELCV 100 F77IBU=CV*(1.0D03/WM) RETURN 300 F77IBU=+1.0E+20 RETURN 600 F77IBU=-1.0E+20 RETURN 900 F77IBU=-1.0E+20 RETURN END C *** CVTDD(T) SPECIFIC HEAT CAPACITY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F78IBU(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N DATA TTRP,TCRT /113.55D00,408.00D00/ DATA TTRPX,TCRTX /113.549D00,408.001D00/ 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=F54IBU(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/(ALO*WM) TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CVG = CVZ + DELCV F78IBU=CVG*(1.0D03/WM) RETURN 300 F78IBU=+1.0E+20 RETURN 600 F78IBU=-1.0E+20 RETURN 900 F78IBU=-1.0E+20 RETURN END C *** WPT(P,T) VELOCITY OF SOUND DOUBLE PRECISION FUNCTION F83IBU(P,T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) INTEGER N REAL TTT,TTP,TTCRT,TTM,TTS DATA PTRP,PCRT/1.8893D-07,36.548852487D00/ DATA TTRP,TCRT /113.55D00,408.00D00/ DATA WM/58.1243D00/ DATA DLT/2.5D-06/ DATA TMAX,PMAX /426.851D00,700.001D00/ TP=F69IBU(P) IF(TP.EQ.-1.0E+20) GO TO 900 TTT=SNGL(T) TTP=SNGL(TP) IF((P.GE.1.8893D-07.AND.P.LT.PMAX) & .AND.(TTT.GE.TTP.AND.T.LE.TMAX)) GO TO 1 GO TO 600 1 ALO=F51IBU(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=F40IBU(P) IF(TSS.EQ.-1.0E+20) GO TO 900 TS=TSS+273.15D00 C TTS=SNGL(TS) C IF(TTM-TTS) 2,30,30 ELSE IF(P.GE.PCRT) THEN IF(TTM-TTCRT) 2,30,30 END IF C 2 CALL S03IBU(TM,DDSDT,DLIQF) DL=DLIQF DDLDT=DDSDT IF(TM.LE.340.0D00) GO TO 9 8 CALL S13IBU(TM,CVSATF) CVS = CVSATF GO TO 10 9 CALL S04IBU(TM,DL,0,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) CALL S12IBU(TM,CSATXF) CVS = CSATXF + 100.0D00*TM*DPDT*DDLDT/DL/DL 10 DX = DB - DL IF(DX) 20,20,11 11 N = DX*10 + 5 CALL S11IBU(0,N,TM,DL,DB,EDELF,DELS,DELCV) CV = CVS + DELCV 13 CALL S04IBU(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 20 CV=CVS CP = CV + 100.0D00*TM/DPDD*(DPDT/DL)**2 W = DSQRT(WK*CP*DPDD/CV) GO TO 100 C 30 TI = TM CALL S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) N = DB*20 + 10 CALL S11IBU(1,N,TM,0.0D00,DB,EDELF,DELS,DELCV) CV = CVZ + DELCV CALL S04IBU(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 F83IBU=W RETURN 600 F83IBU=-1.0E+20 RETURN 900 F83IBU=-1.0E+20 RETURN END C C******************************************************************** C* ******************************** * C* * FUNCTION FOR SETTING UNITS * * C* ******************************** * C******************************************************************** C REAL FUNCTION G98IBU(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 G98IBU=P*PBAR RETURN END REAL FUNCTION G99IBU(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 G99IBU=T-T0K RETURN END C C#################################################################### C******************************************************************** C* **************** * C* * SUBROUTINE * * C* **************** * C******************************************************************** C C *** DPSDT SUBROUTINE S01IBU(T,PSATF,DPSDT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA EPP,TCRT,A,B/1.95D00,408.00D00,13.80835297D00,9.37269200D00/ DATA TTRP/113.55D000/ DATA C,D,E,F /-70.54663008D00,112.75833458D00,-52.42140768D00, 1 47.81122198D00/ 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 S02IBU(T,DDSDT,ZSAT,ZFX,DGASF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AV(3) COMMON/B13/ ZCRT DATA DCRT,TTRP,TCRT/3.86D00,113.55D00,408.00D00/ DATA PCRT/36.548852487D00/ DATA EG, EGX, GKK / 0.35D00, 3.60D00, 0.083145D00 / DATA AV / -0.764051836D00, 0.650501182D00, 30.75066326D00/ 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 S01IBU(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*(1.0D00-1.0D00/V) IF(EGXV.GE.-290.0D00) GO TO 11 XP1 = 0.0D00 XP = 0.0D00 GO TO 12 11 XP = DEXP(EGXV) XP1 = -EGX*XP/V/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 S03IBU(T,DDSDT,DLIQF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AW(3) DATA EL / 0.35D00/ DATA DCRT,DTRP,TTRP,TCRT /3.86D00,12.755D00,113.55D00,408.00D00/ DATA AW / 0.786913448D00, -0.142753535D00, 0.057698164D00/ 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 S04IBU(T,D,M,PVTF,FRT,DFRTDT,DPDT,D2PDT2,DPDR,DPDD) C I-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 S05IBU 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 S06IBU(D,TSATF,DTSDR) TS=TSATF TSAT=TS CALL S01IBU(TS,PSATF,DPSDT) PS=PSATF PSAT=PS CALL S07IBU(D,THETAF,DTHDR) THETA=THETAF CALL S08IBU(T,D,XBF) XB = XBF CALL S09IBU(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 S05IBU C I-BUTANE EQNSTATE, OCT. 23, 1978 AT 10.29. C NEW XEF, DENGASF, 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.95D00 18 TTRP=113.55D00 DTRP=12.755D00 TTRP1=TTRP-273.15D00 PTRP=F30IBU(TTRP1) 19 TCRT=408.00D00 DCRT=3.860D00 TCRT1=TCRT-273.15D00 PCRT=F30IBU(TCRT1) 20 GKK = 0.083145D00 GK = GKK*DCRT ZCRT = PCRT/DCRT/GKK/TCRT 21 IX=4 AL=1.0D00 BE=0.50D00 GA=0.30D00 DE=2.0D00/3.0D00 EP=3.0D00 ER=0.0D00 22 B1=-0.05165511088D+00 B2=0.62315236106D+00 B4=0.0D00 B3=0.0D00 E1=0.42083144154D+00 23 DGAT = 1.0D00/(F54IBU(TTRP1)*WM) 24 WK = 100000.0D00/WM EZZ = 23838.616217D00 RETURN END C C *** TSATF SUBROUTINE S06IBU(DEN,TSATF,DTSDR) C ITERATE T TO MINIMIZE (DEN-DCALC) VIA DENGASF(T), DENLIQF(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 S05IBU 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 S02IBU(TT,DDSDT,ZSAT,ZFX,DGASF) DD = D - DGASF GO TO 9 8 CALL S03IBU(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 S07IBU(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 S05IBU CALL S06IBU(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 S08IBU(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 S05IBU CALL S06IBU(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 S09IBU(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 S05IBU CALL S06IBU(D,TSATF,DTSDR) CALL S07IBU(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 S11IBU(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 S05IBU 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 S04IBU(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 S12IBU(T,CSATXF) C THIS CSATXF(T) VIA ISUTHRM, NOV. 1, 1978. R.D.G. C SSAT = SCRT + A*U**ES + B*LN(X) + C*U + D*U**2 + E*U**3, C WHERE X=T/TCRT, U=(1-X). C CSAT = -ES*A*X/U**(1-ES) + B - C*X - 2*D*X*U - 3*E*X*U**2. IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA ES,TCRT,B,C/0.450D00,408.0D00,-35.97387860D00,87.70514205D00/ DATA D,E,F/-45.80245863D00,0.19432181D00,15.98164931D00/ 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 U = 1.0D00-X XE = U**(1.0D00-ES) CSATXF = -ES*B*X/XE + C - D*X - 2.0D00*E*X*U - 3.0D00*F*X*U*U RETURN END C C *** CVSATF SUBROUTINE S13IBU(T,CVSATF) C ISOBUTANE CV ON SATLIQ BOUNDARY NEAR THE C.P. NOV. 5, 1978. C VALID ONLY FOR T NOT LESS THAN TZ = 340 K. C CV = CVZ + A*X + B*X4/(1-X)**0.1, X=(T-TZ)/(TC-TZ). IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA TZ, TC, TN / 340.0D00, 408.0D00, 68.0D00 / DATA CVZ / 111.87D00 / DATA A, B, E / 13.48D00, 5.38D00, 0.1D00 / IF(T.GE.TZ.AND.T.LT.TC) GO TO 4 GO TO 600 4 X = (T-TZ)/TN X2 = X*X XE = (1.0D00-X)**E CVSATF = CVZ + A*X + B*X2*X2/XE RETURN 600 CVSATF= 0.0D00 RETURN END C C *** IDEAL SUBROUTINE S14IBU(TI,EZ,SZ,HZ,CVZ,CPZ) C I-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(7) DATA R,SI,HI,E/ 8.31450D00, 35.59759D00, 7.26243166D00, 6.40D00 / DATA A / 43.59076D00, -40.54350D00, 739.72837D00, -3137.57293, 1 7742.58382D00, -7583.91994D00, 3251.25208D00/ NK = 7 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 S18IBU(T,QVAPXF) C I-BUTANE, OCT. 27, 1978. R.D.G. C FOR 129 WEIGHTED DATA (INCL. CLAPEYRON), RMS = 0.54 PCNT. C QVAP/QTRP = X + (XE-X)*(A + B*X2 + C*X3), WHERE - C X = (TC-T)/(TC-TT), XE = X**E. IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA E,TTRP,TCRT,XN/0.45D00,113.55D00,408.0D00,294.45D00/ DATA QT/28.208D00/ DATA A,B,C/1.1726829D00,-0.23924905D00,-0.0265020D00/ 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 X2 = X*X XE = X**E 6 Q = QT*(X + (XE-X)*(A + B*X2 + C*X*X2)) 7 QVAPXF = Q*1000.0D00 RETURN END C C *** HSATF SUBROUTINE S19IBU(T,HSATF) C I-BUTANE SATLIQ ENTHALPY, J/MOL. C THIS HSATF(T) VIA IBUTHRM, NOV. 1, 1978. R.D.G. C FOR 30 POINTS, 120 THRU 408 K, RMSPCT = 0.027. C DEFINE YH = (H-HC)/(HT-HC), X = (TC-T)/(TC-TT), WHEN - C YH = X + (XE-X)*(A1 + A2*X +A3*X2 + . . .) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AH(3) DATA TTRP,TCRT/113.55D00,408.00D00/ DATA NFH,EH,HTRP,HCRT/3,0.5D00,0.0D00,43739.182D00/ DATA AH / 0.4016094798D00, 0.4044226707D00, -0.1374834999D00/ X = (TCRT-T)/(TCRT-TTRP) IF(X.GT.0.0D00) GO TO 6 5 HSATF = HCRT RETURN 6 V = X**EH - X FX = X DO 7 K=1,NFH 7 FX = FX + V*AH(K)*X**(K-1) 8 HSATF = HCRT - (HCRT-HTRP)*FX RETURN END C C *** SSATF SUBROUTINE S20IBU(T,SSATF) C I-BUTANE SATLIQ ENTROPY, J/MOL/K. C THIS SSATF(T) VIA IBUTHRM, NOV. 1, 1978. R.D.G. C FOR 31 POINTS, TTRP THRU TCRT, RMSPCT = 0.003. C SSAT - SCRT = A1*U**ES + A2*LN(X) + A3*U + A4*U2 + A5*U3, WHERE - C X = T/TCRT, U = (1-X). IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AS(5) DATA NFS,ES,TCRT,SCRT/5,0.45D00,408.0D00,278.44576D00/ DATA AS / -35.97387860D00, 87.70514205D00, 1 -45.80245863D00, 0.19432181D00, 15.98164931D00/ X = T/TCRT U = 1.0D00 - X IF(U.GT.0.0D00) GO TO 6 5 SSATF = SCRT RETURN 6 SSATF = SCRT + AS(1)*U**ES + AS(2)*DLOG(X) DO 7 K=3,NFS 7 SSATF = SSATF + AS(K)*U**(K-2) RETURN END C C******************************************************************** C* ********************************** * C* * SUBROUTINE FOR ERROR MESSAGE * * C* ********************************** * C******************************************************************** C C *** LEVEL 1 ERROR MESSAGE *** SUBROUTINE S97IBU(FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** NO CONVERGENCE AT '//FUN//' FOR ISOBUTANE ****' WRITE(6,*) MSG END IF RETURN END C *** LEVEL 2 ERROR MESSAGE *** SUBROUTINE S98IBU(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 ISOBUTANE', & ' 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 ISOBUTANE', & ' 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 ISOBUTANE', &' WHEN ',A1,' =',1PE14.7,' AND ',A1,' =',1PE14.7,' ****') END IF END IF RETURN END C *** LEVEL 3 ERROR MESSAGE *** SUBROUTINE S99IBU(FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** FUNCTION '//FUN//' UNAVAILABLE FOR ISOBUTANE ****' 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