C ****************************************** C * PROPATH VER. 9.1 * C * SULFUR HEXAFLUORIDE VER. 1.1 * C * * C * SUPERVISOR [D08SVP.FOR VER. 1.1] * C * CODED BY * C * TOMOHIRO HONDA * C * FUKUOKA UNIVERSITY * C * FUKUOKA 814-01, JAPAN * C * FEBRUARY 1992 * C ****************************************** 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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(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 S99D08(FUN) WTDD=-1.0E+30 RETURN END C C==================================================================== C------------------------------------------------- F1 = AIPPT FUNCTION AIPPT(P,T) CHARACTER FUN*6 DATA FUN/'AIPPT'/ CALL S99D08(FUN) AIPPT=-1.0E+30 RETURN END C------------------------------------------------- F94 = AJTPT FUNCTION AJTPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'AJTPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F94D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - AJTPT=FF RETURN END C------------------------------------------------- F82 = AKPT REAL FUNCTION AKPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'AKPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F82D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AKPT=FF RETURN END C------------------------------------------------- F2 = ALAPP REAL FUNCTION ALAPP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALAPP'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F2D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALAPP=FF RETURN END C------------------------------------------------- F3 = ALAPT REAL FUNCTION ALAPT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALAPT'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F3D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALAPT=FF RETURN END C------------------------------------------------- F4 = ALHP REAL FUNCTION ALHP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALHP'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F4D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'ALHT'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F5D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALHT=FF RETURN END C------------------------------------------------- F6 = ALMPD REAL FUNCTION ALMPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALMPD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F6D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMPD=FF RETURN END C------------------------------------------------- F7 = ALMPDD REAL FUNCTION ALMPDD(P) CHARACTER FUN*6 DATA FUN/'ALMPDD'/ CALL S99D08(FUN) ALMPDD=-1.0E+30 RETURN END C------------------------------------------------- F8 = ALMPT REAL FUNCTION ALMPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'ALMPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F8D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - ALMPT=FF RETURN END C------------------------------------------------- F9 = ALMTD REAL FUNCTION ALMTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALMTD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F9D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMTD=FF RETURN END C------------------------------------------------- F10 = ALMTDD REAL FUNCTION ALMTDD(T) CHARACTER FUN*6 DATA FUN/'ALMTDD'/ CALL S99D08(FUN) ALMTDD=-1.0E+30 RETURN END C------------------------------------------------- F11 = AMUPD REAL FUNCTION AMUPD(P) CHARACTER FUN*6 DATA FUN/'AMUPD'/ CALL S99D08(FUN) AMUPD=-1.0E+30 RETURN END C------------------------------------------------- F12 = AMUPDD REAL FUNCTION AMUPDD(P) CHARACTER FUN*6 DATA FUN/'AMUPDD'/ CALL S99D08(FUN) AMUPDD=-1.0E+30 RETURN END C------------------------------------------------- F13 = AMUPT REAL FUNCTION AMUPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'AMUPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F13D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - AMUPT=FF RETURN END C------------------------------------------------- F14 = AMUTD REAL FUNCTION AMUTD(T) CHARACTER FUN*6 DATA FUN/'AMUTD'/ CALL S99D08(FUN) AMUTD=-1.0E+30 RETURN END C------------------------------------------------- F15 = AMUTDD REAL FUNCTION AMUTDD(T) CHARACTER FUN*6 DATA FUN/'AMUTDD'/ CALL S99D08(FUN) AMUTDD=-1.0E+30 RETURN END C------------------------------------------------- F90 = BSPT FUNCTION BSPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'BSPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F90D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - BSPT=FF RETURN END C------------------------------------------------- F91 = BTPT FUNCTION BTPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'BTPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F91D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - BTPT=FF RETURN END C------------------------------------------------- F92 = BPPT FUNCTION BPPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'BPPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F92D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - BPPT=FF RETURN END C------------------------------------------------- F93 = BVPT FUNCTION BVPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'BVPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F93D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - BVPT=FF RETURN END C------------------------------------------------- F16 = CPPD REAL FUNCTION CPPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CPPD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F16D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'CPPDD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F17D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'CPPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F18D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'CPTD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F19D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'CPTDD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F20D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPTDD=FF RETURN END C------------------------------------------------- F21 = CRP REAL FUNCTION CRP(A) CHARACTER FUN*6,A*1 REAL T0K,PBAR,FF C--- FUNCTION NAME -- DATA FUN/'CRP'/ C--- SET OF UNIT -- C--- FUNCTION CALL -- FF = F21D08(A) C--- LEVEL 2 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+20) THEN WRITE(6,6010) FUN,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ', & ' SULFUR HEXAFLUORIDE WHEN A=',A,' ****') C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ELSEIF (A.EQ.'T') THEN T0K=-G99D08(0.0) FF=FF+T0K ELSEIF (A.EQ.'P') THEN PBAR=G98D08(1.0) FF=FF/PBAR END IF CRP=FF RETURN END C------------------------------------------------- F76 = CVPDD REAL FUNCTION CVPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CVPDD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F76D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'CVPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F77D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'CVTDD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F78D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CVTDD=FF RETURN END C------------------------------------------------- F22 = EPSPT REAL FUNCTION EPSPT(P,T) CHARACTER FUN*6 DATA FUN/'EPSPT'/ CALL S99D08(FUN) EPSPT=-1.0E+30 RETURN END C------------------------------------------------- F89 = FC C************************************************ C FUNCTION FOR FUNDAMENTAL CONSTANTS C PROPATH VER.7.1, MAY 8, 1990 (ORIGINAL) C USAGE: B=FC(A) C A, B : CHARACTER TYPE VALIABLES C B='146.05' WHEN A='M' C B='56.928' WHEN A='R' C************************************************ FUNCTION FC(AFC) REAL FC CHARACTER FUN*2,AFC*1 CHARACTER FLUID*19,MSG*70 COMMON/UNIT/KPA,MESS DATA FUN/'FC'/ DATA FLUID/'SULFUR HEXAFLUORIDE'/ IF (AFC.EQ.'M') THEN FC=146.05 ELSE IF (AFC.EQ.'R') THEN FC=56.928 ELSE FC=-1.0E+20 IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT '//FUN//' FOR '//FLUID// & ' WHEN A='''//AFC//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C-------------------------------------------------- F96 = GAMPDD FUNCTION GAMPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME - DATA FUN/'GAMPDD'/ C--- SET OF UNIT - PI=G98D08(P) C--- FUNCTION CALL - FF = F96D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - GAMPDD=FF RETURN END C------------------------------------------------- F95 = GAMPT FUNCTION GAMPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME - DATA FUN/'GAMPT'/ C--- SET OF UNIT - PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL - FF = F95D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - GAMPT=FF RETURN END C------------------------------------------------- F97 = GAMTDD FUNCTION GAMTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME - DATA FUN/'GAMTDD'/ C--- SET OF UNIT - TI=G99D08(T) C--- FUNCTION CALL - FF = F97D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - GAMTDD=FF RETURN END C------------------------------------------------- F23 = HPD REAL FUNCTION HPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'HPD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F23D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'HPDD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F24D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPDD=FF RETURN END C------------------------------------------------- F71 = HPS REAL FUNCTION HPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'HPS'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F71D08(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPS=FF RETURN END C------------------------------------------------- F25 = HPT REAL FUNCTION HPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'HPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F25D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPT=FF RETURN END C------------------------------------------------- F26 = HPX REAL FUNCTION HPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'HPX'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F26D08(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPX=FF RETURN END C------------------------------------------------- F27 = HTD REAL FUNCTION HTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F27D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'HTDD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F28D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HTDD=FF RETURN END C------------------------------------------------- F29 = HTX REAL FUNCTION HTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTX'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F29D08(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HTX=FF 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='SULFUR HEXAFLUORIDE' WHEN A='S' C B='SF6' WHEN A='C' C B='12.1' WHEN A='V' C************************************************ FUNCTION IDENTF(IDF) CHARACTER IDENTF*20,FUN*6,IDF*1 CHARACTER FLUID*19,MSG*70 COMMON/UNIT/KPA,MESS DATA FUN/'IDENTF'/ DATA FLUID/'SULFUR HEXAFLUORIDE'/ IF (IDF.EQ.'S') THEN IDENTF='SULFUR HEXAFLUORIDE' ELSE IF (IDF.EQ.'C') THEN IDENTF='SF6' ELSE IF (IDF.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT '//FUN//' FOR '//FLUID// & ' WHEN A='''//IDF//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F66 = PLDT FUNCTION PLDT(T) CHARACTER FUN*6 DATA FUN/'PLDT'/ CALL S99D08(FUN) PLDT=-1.0E+30 RETURN END C------------------------------------------------- F68 = PMLT FUNCTION PMLT(T) CHARACTER FUN*6 DATA FUN/'PMLT'/ CALL S99D08(FUN) PMLT=-1.0E+30 RETURN END C------------------------------------------------- F85 = PRPD FUNCTION PRPD(P) CHARACTER FUN*6 DATA FUN/'PRPD'/ CALL S99D08(FUN) PRPD=-1.0E+30 RETURN END C------------------------------------------------- F86 = PRPDD FUNCTION PRPDD(P) CHARACTER FUN*6 DATA FUN/'PRPDD'/ CALL S99D08(FUN) PRPDD=-1.0E+30 RETURN END C------------------------------------------------- F81 = PRPT FUNCTION PRPT(P,T) CHARACTER FUN*6 REAL PRPT,P,T,FF C--- FUNCTION NAME -- DATA FUN/'PRPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F81D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRPT=FF RETURN END C------------------------------------------------- F87 = PRTD FUNCTION PRTD(T) CHARACTER FUN*6 DATA FUN/'PRTD'/ CALL S99D08(FUN) PRTD=-1.0E+30 RETURN END C------------------------------------------------- F88 = PRTDD FUNCTION PRTDD(T) CHARACTER FUN*6 DATA FUN/'PRTDD'/ CALL S99D08(FUN) PRTDD=-1.0E+30 RETURN END C------------------------------------------------- F99 = PSBT FUNCTION PSBT(T) CHARACTER FUN*6 DATA FUN/'PSBT'/ CALL S99D08(FUN) PSBT=-1.0E+30 RETURN END C------------------------------------------------- F30 = PST REAL FUNCTION PST(T) CHARACTER FUN*6 REAL PBAR,T,FF C--- FUNCTION NAME -- DATA FUN/'PST'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F30D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) PBAR=1.0E+00 C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) PBAR=1.0E+00 ELSE PBAR=G98D08(1.0) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PST=FF/PBAR RETURN END C------------------------------------------------- F72 = PSTD FUNCTION PSTD(T) CHARACTER FUN*6 DATA FUN/'PSTD'/ CALL S99D08(FUN) PSTD=-1.0E+30 RETURN END C------------------------------------------------- F73 = PSTDD FUNCTION PSTDD(T) CHARACTER FUN*6 DATA FUN/'PSTDD'/ CALL S99D08(FUN) PSTDD=-1.0E+30 RETURN END C------------------------------------------------- F31 = SIGP REAL FUNCTION SIGP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SIGP'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F31D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSEIF (FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SIGP=FF RETURN END C------------------------------------------------- F32 = SIGT REAL FUNCTION SIGT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'SIGT'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F32D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF (FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSEIF (FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SIGT=FF RETURN END C------------------------------------------------- F33 = SPD REAL FUNCTION SPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SPD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F33D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'SPDD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F34D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'SPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F35D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPT=FF RETURN END C------------------------------------------------- F36 = SPX REAL FUNCTION SPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'SPX'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F36D08(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPX=FF RETURN END C------------------------------------------------- F37 = STD REAL FUNCTION STD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F37D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'STDD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F38D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- STDD=FF RETURN END C------------------------------------------------- F39 = STX REAL FUNCTION STX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STX'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F39D08(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- STX=FF RETURN END C------------------------------------------------- F67 = TLDP FUNCTION TLDP(P) CHARACTER FUN*6 DATA FUN/'TLDP'/ CALL S99D08(FUN) TLDP=-1.0E+30 RETURN END C------------------------------------------------- F69 = TMLP FUNCTION TMLP(P) CHARACTER FUN*6 DATA FUN/'TMLP'/ CALL S99D08(FUN) TMLP=-1.0E+30 RETURN END C------------------------------------------------- F64 = TPH REAL FUNCTION TPH(P,H) CHARACTER FUN*6 REAL T0K,P,H,FF C--- FUNCTION NAME -- DATA FUN/'TPH'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F64D08(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) T0K=0.0E+00 C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,H,'P','H',FUN) T0K=0.0E+00 ELSE T0K=-G99D08(0.0) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPH=FF+T0K RETURN END C------------------------------------------------- F98 = TPSEUP FUNCTION TPSEUP(P) CHARACTER FUN*6 REAL P,FF DATA FUN/'TPSEUP'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F98D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) T0K=0.0E+00 C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) T0K=0.0E+00 ELSE T0K=-G99D08(0.0) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPSEUP=FF+T0K RETURN END C------------------------------------------------- F65 = TPS REAL FUNCTION TPS(P,S) CHARACTER FUN*6 REAL T0K,P,S,FF C--- FUNCTION NAME -- DATA FUN/'TPS'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F65D08(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) T0K=0.0E+00 C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,S,'P','S',FUN) T0K=0.0E+00 ELSE T0K=-G99D08(T) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPS=FF+T0K RETURN END C------------------------------------------------- F70 = TPV REAL FUNCTION TPV(P,V) CHARACTER FUN*6 REAL T0K,P,V,FF C--- FUNCTION NAME -- DATA FUN/'TPV'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F70D08(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) T0K=0.0E+00 C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,V,'P','V',FUN) T0K=0.0E+00 ELSE T0K=-G99D08(0.0) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPV=FF+T0K RETURN END C------------------------------------------------- F41 = TRPL REAL FUNCTION TRPL(A) CHARACTER A*1 CHARACTER FUN*6 DATA FUN/'TRPL'/ CALL S99D08(FUN) TRPL=-1.0E+30 RETURN END C------------------------------------------------- F100 = TSBP FUNCTION TSBP(P) CHARACTER FUN*6 DATA FUN/'TSBP'/ CALL S99D08(FUN) TSBP=-1.0E+30 RETURN END C------------------------------------------------- F40 = TSP REAL FUNCTION TSP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'TSP'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F40D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) T0K=0.0E+00 C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) T0K=0.0E+00 ELSE T0K=-G99D08(0.0) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TSP=FF+T0K RETURN END C------------------------------------------------- F74 = TSPD FUNCTION TSPD(P) CHARACTER FUN*6 DATA FUN/'TSPD'/ CALL S99D08(FUN) TSPD=-1.0E+30 RETURN END C------------------------------------------------- F75 = TSPDD FUNCTION TSPDD(P) CHARACTER FUN*6 DATA FUN/'TSPDD'/ CALL S99D08(FUN) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F42 = UPD REAL FUNCTION UPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'UPD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F42D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'UPDD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F43D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPDD=FF RETURN END C------------------------------------------------- F79 = UPS REAL FUNCTION UPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'UPS'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F79D08(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPS=FF RETURN END C------------------------------------------------- F44 = UPT REAL FUNCTION UPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'UPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F44D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPT=FF RETURN END C------------------------------------------------- F45 = UPX REAL FUNCTION UPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'UPX'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F45D08(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPX=FF RETURN END C------------------------------------------------- F46 = UTD REAL FUNCTION UTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F46D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'UTDD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F47D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTDD=FF RETURN END C------------------------------------------------- F48 = UTX REAL FUNCTION UTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTX'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F48D08(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTX=FF RETURN END C------------------------------------------------- F49 = VPD REAL FUNCTION VPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'VPD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F49D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'VPDD'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F50D08(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPDD=FF RETURN END C------------------------------------------------- F80 = VPS REAL FUNCTION VPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'VPS'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F80D08(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPS=FF RETURN END C------------------------------------------------- F51 = VPT REAL FUNCTION VPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'VPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F51D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPT=FF RETURN END C------------------------------------------------- F52 = VPX REAL FUNCTION VPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'VPX'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F52D08(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPX=FF RETURN END C------------------------------------------------- F53 = VTD REAL FUNCTION VTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F53D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) 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 C--- FUNCTION NAME -- DATA FUN/'VTDD'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F54D08(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTDD=FF RETURN END C------------------------------------------------- F55 = VTX REAL FUNCTION VTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTX'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F55D08(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTX=FF RETURN END C------------------------------------------------- F83 = WPT REAL FUNCTION WPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'WPT'/ C--- SET OF UNIT -- PI=G98D08(P) TI=G99D08(T) C--- FUNCTION CALL -- FF = F83D08(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- WPT=FF RETURN END C------------------------------------------------- F56 = XPH REAL FUNCTION XPH(P,H) CHARACTER FUN*6 REAL P,H,FF C--- FUNCTION NAME -- DATA FUN/'XPH'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F56D08(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,H,'P','H',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPH=FF RETURN END C------------------------------------------------- F57 = XPS REAL FUNCTION XPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'XPS'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F57D08(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPS=FF RETURN END C------------------------------------------------- F58 = XPU REAL FUNCTION XPU(P,U) CHARACTER FUN*6 REAL P,U,FF C--- FUNCTION NAME -- DATA FUN/'XPU'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F58D08(PI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,U,'P','U',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPU=FF RETURN END C------------------------------------------------- F59 = XPV REAL FUNCTION XPV(P,V) CHARACTER FUN*6 REAL P,V,FF C--- FUNCTION NAME -- DATA FUN/'XPV'/ C--- SET OF UNIT -- PI=G98D08(P) C--- FUNCTION CALL -- FF = F59D08(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,P,V,'P','V',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPV=FF RETURN END C------------------------------------------------- F60 = XTH REAL FUNCTION XTH(T,H) CHARACTER FUN*6 REAL T,H,FF C--- FUNCTION NAME -- DATA FUN/'XTH'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F60D08(TI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,H,'T','H',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTH=FF RETURN END C------------------------------------------------- F61 = XTS REAL FUNCTION XTS(T,S) CHARACTER FUN*6 REAL T,S,FF C--- FUNCTION NAME -- DATA FUN/'XTS'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F61D08(TI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,S,'T','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTS=FF RETURN END C------------------------------------------------- F62 = XTU REAL FUNCTION XTU(T,U) CHARACTER FUN*6 REAL T,U,FF C--- FUNCTION NAME -- DATA FUN/'XTU'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F62D08(TI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,U,'T','U',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTU=FF RETURN END C------------------------------------------------- F63 = XTV REAL FUNCTION XTV(T,V) CHARACTER FUN*6 REAL T,V,FF C--- FUNCTION NAME -- DATA FUN/'XTV'/ C--- SET OF UNIT -- TI=G99D08(T) C--- FUNCTION CALL -- FF = F63D08(TI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D08(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D08(3,T,V,'T','V',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTV=FF RETURN END C *** FUNCTION FOR SETTING UNITS **** C G98 *** FUNCTION G98D08(P) REAL P,G98D08 DOUBLE PRECISION PBAR INTEGER KPA,MESS COMMON/UNIT/KPA,MESS IF(KPA.EQ.1) THEN PBAR=1.0D+00 ELSE IF(KPA.EQ.2) THEN PBAR=1.0D+00 ELSE IF(KPA.EQ.3) THEN PBAR=1.0D-05 ELSE PBAR=1.0D-05 END IF G98D08=REAL(DBLE(P)*PBAR) RETURN END C G99 *** FUNCTION G99D08(T) REAL T,G99D08 DOUBLE PRECISION T0K INTEGER KPA,MESS COMMON/UNIT/KPA,MESS IF(KPA.EQ.1) THEN T0K=0.0D+00 ELSE IF(KPA.EQ.2) THEN T0K=273.15D+00 ELSE IF(KPA.EQ.3) THEN T0K=0.0D+00 ELSE T0K=273.15D+00 END IF G99D08=REAL(DBLE(T)-T0K) RETURN END C ******* SUBROUTINE FOR ERROR MESSAGE ******* C *** LEVEL 1 ERROR MESSAGE -- SUBROUTINE S97D08(FUN) CHARACTER FUN*6,FLUID*20 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA FLUID/'SULFUR HEXAFLUORIDE '/ IF (MESS.NE.0) THEN WRITE(6,100) FUN,FLUID 100 FORMAT(1H ,5X,'**** NO CONVERGENCE AT ',A6,' FOR ',A20,'****') ENDIF RETURN END C *** LEVEL 2 ERROR MESSAGE -- SUBROUTINE S98D08(IPT,P,T,N1,N2,FUN) CHARACTER FUN*6,N1*1,N2*1,FLUID*20 REAL P,T INTEGER KPA,MESS,IPT COMMON/UNIT/KPA,MESS DATA FLUID/'SULFUR HEXAFLUORIDE '/ IF (MESS.NE.0) THEN IF (IPT.EQ.1) THEN C--- FUN(P) TYPE WRITE(6,6010) FUN,FLUID,P 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A20, & ' WHEN P =',1PE14.7,' ****') C--- FUN(T) TYPE ELSEIF (IPT.EQ.2) THEN WRITE(6,6020) FUN,FLUID,T 6020 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A20, & ' WHEN T =',1PE14.7,' ****') C--- FUN(P,T) TYPE ELSE WRITE(6,6030) FUN,FLUID,N1,P,N2,T 6030 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A20, & ' WHEN ',A1,' =',1PE14.7,' AND ',A1,' =',1PE14.7,' ****') ENDIF ENDIF RETURN END C *** LEVEL 3 ERROR MESSAGE -- SUBROUTINE S99D08(FUN) CHARACTER FUN*6,FLUID*20 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA FLUID/'SULFUR HEXAFLUORIDE '/ IF (MESS.NE.0) THEN WRITE(6,100) FUN,FLUID 100 FORMAT(1H ,5X,'**** FUNCTION ',A6,' UNAVAILABLE FOR ',A20,'****') ENDIF RETURN END C **************************************** C * SF6 F--D08 FUNCTIONS * C * * C * UNIT NAME [D08FUN.FOR VER.1.1 ] * C * * C * CODED BY * C * TOMOHIRO HONDA * C * FUKUOKA UNIVERSITY * C * FUKUOKA 814-01, JAPAN * C * FEBRUARY 1992 * C **************************************** C F02 + LAPLACE COEFFICIENT AT P FUNCTION F2D08(P) IMPLICIT DOUBLE PRECISION (Y) IF (P.LT.2.2502 .OR. P.GE.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 TK=REAL(YTS) F2D08=SQRT(G4D08(TK)/(REAL(YRL-YRG))/9.80665) RETURN 999 F2D08=-1.0E+20 RETURN END C F03 + LAPLACE COEFFICIENT AT T FUNCTION F3D08(T) IMPLICIT DOUBLE PRECISION (Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 TK=T+273.15 YT=DBLE(TK) CALL S1D08(YT,YPS,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 F3D08=SQRT(G4D08(TK)/(REAL(YRL-YRG))/9.80665) RETURN 999 F3D08=-1.0E+20 RETURN END C F04 + LATENT HEAT OF VAPORIZATION AT P FUNCTION F4D08(P) IMPLICIT DOUBLE PRECISION (G,H,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) HL=G13D08(YRL,YTS,YP) HG=G13D08(YRG,YTS,YP) F4D08=REAL(HG-HL) RETURN 999 F4D08=-1.0E+20 RETURN END C F05 + LATENT HEAT OF VAPORIZATION AT T FUNCTION F5D08(T) IMPLICIT DOUBLE PRECISION (G,H,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) HL=G13D08(YRL,YT,YPS) HG=G13D08(YRG,YT,YPS) F5D08=REAL(HG-HL) RETURN 999 F5D08=-1.0E+20 RETURN END C F06 + LUMDA OF SATURATED LIQUID AT P FUNCTION F6D08(P) IF (P.GE.2.8505 .AND. P.LE.12.590) THEN T=F40D08(P) F6D08=0.0648-0.00038*T ELSE F6D08=-1.0E+20 ENDIF RETURN END C F08 + LUMDA AT P AND T FUNCTION F8D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.25.0 .AND. T.LE.100.0) THEN PMAX=0.653*T+4.3 IF (P.GE.0.1 .AND. P.LE.PMAX) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F8D08=REAL(G20D08(YR,YT)) RETURN ENDIF ENDIF F8D08=-1.0E+20 RETURN END C F09 + LUMDA OF SATURATED LIQUID AT T FUNCTION F9D08(T) IF (T.GE.-45.0 .AND. T.LE.0.0) THEN F9D08=0.0648-0.00038*T ELSE F9D08=-1.0E+20 ENDIF RETURN END C F13 + MYU AT P AND T FUNCTION F13D08(P,T) CHARACTER FLUID*19 DOUBLE PRECISION AMYU,TK,A1,B1,C1,D1,A2,B2,C2,D2 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA A1,B1,C1,D1 1/0.4420776D+00,-2.360078D+02,1.616337D+04,3.112D+00/ DATA A2,B2,C2,D2 1/0.5145973D+00,-1.901002D+02,1.050020D+04,2.618D+00/ DATA FLUID/'SULFUR HEXAFLUORIDE'/ IF (MESS.NE.0) THEN DP=ABS(P/1.01325-1.0) IF (DP.GT.2.0E-02) THEN WRITE(6,100) FLUID 100 FORMAT(1H ,5X,'**** WARNING : AMUPT(P,T) IS ', & 'COEFFICIENT OF VISCOSITY AT ORDINARY PRESSURE', & '(1.01325 BAR) FOR ',A19,' ****') ENDIF ENDIF TK=DBLE(T)+273.15D+00 IF (TK.GE.218.3D+00 .AND. TK.LE.900D+00) THEN IF (TK.LE.302.2D+00) THEN AMYU=A1*DLOG(TK)+B1/TK+C1/TK/TK+D1 ELSE AMYU=A2*DLOG(TK)+B2/TK+C2/TK/TK+D2 ENDIF F13D08=REAL(DEXP(AMYU))*1.0E-07 ELSE F13D08=-1.0E+20 ENDIF RETURN END C F16 + CP OF SATURATED LIQUID AT P FUNCTION F16D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GE.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 F16D08=REAL(G11D08(YRL,YTS)) RETURN 999 F16D08=-1.0E+20 RETURN END C F17 + CP OF SATURATED VAPOUR AT P FUNCTION F17D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GE.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 F17D08=REAL(G11D08(YRG,YTS)) RETURN 999 F17D08=-1.0E+20 RETURN END C F18 + CP AT P AND T FUNCTION F18D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) DATA YRCR /728.51D+00/ IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) IF (YR.NE.YRCR) THEN F18D08=REAL(G11D08(YR,YT)) RETURN ENDIF ENDIF ENDIF F18D08=-1.0E+20 RETURN END C F19 + CP OF SATURATED LIQUID AT T FUNCTION F19D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 F19D08=REAL(G11D08(YRL,YT)) RETURN 999 F19D08=-1.0E+20 RETURN END C F20 + CP OF SATURATED VAPOUR AT T FUNCTION F20D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 F20D08=REAL(G11D08(YRG,YT)) RETURN 999 F20D08=-1.0E+20 RETURN END C F21 + CRITICAL POINT FUNCTION F21D08(A) IMPLICIT DOUBLE PRECISION (G) CHARACTER*1 A DATA GP,GT,GR/3.7641D+06,318.748D+00,728.51D+00/ IF (A.EQ.'H') THEN F21D08=REAL(G13D08(GR,GT,GP)) ELSEIF (A.EQ.'P') THEN F21D08=REAL(GP*1.0D-05) ELSEIF (A.EQ.'S') THEN F21D08=REAL(G15D08(GR,GT)) ELSEIF (A.EQ.'T') THEN F21D08=REAL(GT-273.15D+00) ELSEIF (A.EQ.'V') THEN F21D08=1.0E+00/REAL(GR) ELSE F21D08=-1.0E+20 ENDIF RETURN END C F23 + H OF SATURATED LIQUID AT P FUNCTION F23D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) F23D08=REAL(G13D08(YRL,YTS,YP)) RETURN 999 F23D08=-1.0E+20 RETURN END C F24 + H OF SATURATED VAPOUR AT P FUNCTION F24D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) F24D08=REAL(G13D08(YRG,YTS,YP)) RETURN 999 F24D08=-1.0E+20 RETURN END C F25 + H AT P AND T FUNCTION F25D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F25D08=REAL(G13D08(YR,YT,YP)) RETURN ENDIF ENDIF F25D08=-1.0E+20 RETURN END C F26 + H OF MIXTURE AT P FUNCTION F26D08(P,X) IMPLICIT DOUBLE PRECISION (G,H,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YP=DBLE(P)*1.0D+05 YX=DBLE(X) CALL S2D08(YP,YTS,YRL,YRG) HL=G13D08(YRL,YTS,YP) HG=G13D08(YRG,YTS,YP) F26D08=REAL(HL+YX*(HG-HL)) RETURN 999 F26D08=-1.0E+20 RETURN END C F27 + H OF SATURATED LIQUID AT T FUNCTION F27D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) F27D08=REAL(G13D08(YRL,YT,YPS)) RETURN 999 F27D08=-1.0E+20 RETURN END C F28 + H OF SATURATED VAPOUR AT T FUNCTION F28D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) F28D08=REAL(G13D08(YRG,YT,YPS)) RETURN 999 F28D08=-1.0E+20 RETURN END C F29 + H OF MIXTURE AT T FUNCTION F29D08(T,X) IMPLICIT DOUBLE PRECISION (G,H,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YT=DBLE(T+273.15) YX=DBLE(X) CALL S1D08(YT,YPS,YRL,YRG) HL=G13D08(YRL,YT,YPS) HG=G13D08(YRG,YT,YPS) F29D08=REAL(HL+YX*(HG-HL)) RETURN 999 F29D08=-1.0E+20 RETURN END C F30 + SATURATION PRESSURE AT T FUNCTION F30D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YP,YRL,YRG) F30D08=REAL(YP)*1.0E-05 RETURN 999 F30D08=-1.0E+20 RETURN END C F31 + SURFACE TENSION AT P FUNCTION F31D08(P) IMPLICIT DOUBLE PRECISION (Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) TK=REAL(YTS) F31D08=G4D08(TK) RETURN 999 F31D08=-1.0E+20 RETURN END C F32 + SURFACE TENSION AT T FUNCTION F32D08(T) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 TK=T+273.15 F32D08=G4D08(TK) RETURN 999 F32D08=-1.0E+20 RETURN END C F33 + S OF SATURATED LIQUID AT P FUNCTION F33D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) F33D08=REAL(G15D08(YRL,YTS)) RETURN 999 F33D08=-1.0E+20 RETURN END C F34 + S OF SATURATED VAPOUR AT P FUNCTION F34D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) F34D08=REAL(G15D08(YRG,YTS)) RETURN 999 F34D08=-1.0E+20 RETURN END C F35 + S AT P AND T FUNCTION F35D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F35D08=REAL(G15D08(YR,YT)) RETURN ENDIF ENDIF F35D08=-1.0E+20 RETURN END C F36 + S OF MIXTURE AT P FUNCTION F36D08(P,X) IMPLICIT DOUBLE PRECISION (G,S,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YP=DBLE(P)*1.0D+05 YX=DBLE(X) CALL S2D08(YP,YTS,YRL,YRG) SL=G15D08(YRL,YTS) SG=G15D08(YRG,YTS) F36D08=REAL(SL+YX*(SG-SL)) RETURN 999 F36D08=-1.0E+20 RETURN END C F37 + S OF SATURATED LIQUID AT T FUNCTION F37D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) F37D08=REAL(G15D08(YRL,YT)) RETURN 999 F37D08=-1.0E+20 RETURN END C F38 + S OF SATURATED VAPOUR AT T FUNCTION F38D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) F38D08=REAL(G15D08(YRG,YT)) RETURN 999 F38D08=-1.0E+20 RETURN END C F39 + S OF MIXTURE AT T FUNCTION F39D08(T,X) IMPLICIT DOUBLE PRECISION (G,S,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YT=DBLE(T+273.15) YX=DBLE(X) CALL S1D08(YT,YPS,YRL,YRG) SL=G15D08(YRL,YT) SG=G15D08(YRG,YT) F39D08=REAL(SL+YX*(SG-SL)) RETURN 999 F39D08=-1.0E+20 RETURN END C F40 + SATURATION TEMPERATURE AT P FUNCTION F40D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YT,YRL,YRG) F40D08=REAL(YT)-273.15 RETURN 999 F40D08=-1.0E+20 RETURN END C F41 + CRITICAL POINT FUNCTION F41D08(A) DOUBLE PRECISION GT CHARACTER*1 A DATA GT/222.35D+00/ IF (A.EQ.'P') THEN F41D08=2.2502 ELSEIF (A.EQ.'T') THEN F41D08=REAL(GT-273.15D+00) ELSE F41D08=-1.0E+20 ENDIF RETURN END C F42 + U OF SATURATED LIQUID AT P FUNCTION F42D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) F42D08=REAL(G12D08(YRL,YTS)) RETURN 999 F42D08=-1.0E+20 RETURN END C F43 + U OF SATURATED VAPOUR AT P FUNCTION F43D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,YRL,YRG) F43D08=REAL(G12D08(YRG,YTS)) RETURN 999 F43D08=-1.0E+20 RETURN END C F44 + U AT P AND T FUNCTION F44D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F44D08=REAL(G12D08(YR,YT)) RETURN ENDIF ENDIF F44D08=-1.0E+20 RETURN END C F45 + U OF MIXTURE AT P FUNCTION F45D08(P,X) IMPLICIT DOUBLE PRECISION (G,U,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YP=DBLE(P)*1.0D+05 YX=DBLE(X) CALL S2D08(YP,YTS,YRL,YRG) UL=G12D08(YRL,YTS) UG=G12D08(YRG,YTS) F45D08=REAL(UL+YX*(UG-UL)) RETURN 999 F45D08=-1.0E+20 RETURN END C F46 + U OF SATURATED LIQUID AT T FUNCTION F46D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) F46D08=REAL(G12D08(YRL,YT)) RETURN 999 F46D08=-1.0E+20 RETURN END C F47 + U OF SATURATED VAPOUR AT T FUNCTION F47D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) F47D08=REAL(G12D08(YRG,YT)) RETURN 999 F47D08=-1.0E+20 RETURN END C F48 + U OF MIXTURE AT T FUNCTION F48D08(T,X) IMPLICIT DOUBLE PRECISION (G,U,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YT=DBLE(T+273.15) YX=DBLE(X) CALL S1D08(YT,YPS,YRL,YRG) UL=G12D08(YRL,YT) UG=G12D08(YRG,YT) F48D08=REAL(UL+YX*(UG-UL)) RETURN 999 F48D08=-1.0E+20 RETURN END C F49 + V OF SATURATED LIQUID AT P FUNCTION F49D08(P) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,RL,RG) F49D08=1.0E+00/(REAL(RL)) RETURN 999 F49D08=-1.0E+20 RETURN END C F50 + V OF SATURATED GAS AT P FUNCTION F50D08(P) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,RL,RG) F50D08=1.0E+00/(REAL(RG)) RETURN 999 F50D08=-1.0E+20 RETURN END C F51 + V AT P AND T FUNCTION F51D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F51D08=1.0E+00/(REAL(YR)) RETURN ENDIF ENDIF F51D08=-1.0E+20 RETURN END C F52 + V OF MIXTURE AT P FUNCTION F52D08(P,X) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,RL,RG) VL=1.0E+00/(REAL(RL)) VG=1.0E+00/(REAL(RG)) F52D08=VL+X*(VG-VL) RETURN 999 F52D08=-1.0E+20 RETURN END C F53 + V OF SATURATED LIQUID AT T FUNCTION F53D08(T) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,RL,RG) F53D08=1.0E+00/(REAL(RL)) RETURN 999 F53D08=-1.0E+20 RETURN END C F54 + V OF SATURATED GAS AT T FUNCTION F54D08(T) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,RL,RG) F54D08=1.0E+00/(REAL(RG)) RETURN 999 F54D08=-1.0E+20 RETURN END C F55 + V OF MIXTURE AT T FUNCTION F55D08(T,X) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,RL,RG) VL=1.0E+00/(REAL(RL)) VG=1.0E+00/(REAL(RG)) F55D08=VL+X*(VG-VL) RETURN 999 F55D08=-1.0E+20 RETURN END C F56 + DRYNESS FRACTION <-> AT P,H FUNCTION F56D08(P,H) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YT,RL,RG) IF (RL.EQ.RG) GOTO 999 HD=REAL(G13D08(RL,YT,YP)) HDD=REAL(G13D08(RG,YT,YP)) IF (H.LT.HD .OR. H.GT.HDD) GOTO 999 F56D08=(H-HD)/(HDD-HD) RETURN 999 F56D08=-1.0E+20 RETURN END C F57 + DRYNESS FRACTION <-> AT P,S FUNCTION F57D08(P,S) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YT,RL,RG) IF (RL.EQ.RG) GOTO 999 SD=REAL(G15D08(RL,YT)) SDD=REAL(G15D08(RG,YT)) IF (S.LT.SD .OR. S.GT.SDD) GOTO 999 F57D08=(S-SD)/(SDD-SD) RETURN 999 F57D08=-1.0E+20 RETURN END C F58 + DRYNESS FRACTION <-> AT P,U FUNCTION F58D08(P,U) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YT,RL,RG) IF (RL.EQ.RG) GOTO 999 UD=REAL(G12D08(RL,YT)) UDD=REAL(G12D08(RG,YT)) IF (U.LT.UD .OR. U.GT.UDD) GOTO 999 F58D08=(U-UD)/(UDD-UD) RETURN 999 F58D08=-1.0E+20 RETURN END C F59 + DRYNESS FRACTION <-> AT P,V FUNCTION F59D08(P,V) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YT,RL,RG) IF (RL.EQ.RG) GOTO 999 VL=1.0E+00/(REAL(RL)) VG=1.0E+00/(REAL(RG)) IF (V.LT.VL .OR. V.GT.VG) GOTO 999 F59D08=(V-VL)/(VG-VL) RETURN 999 F59D08=-1.0E+20 RETURN END C F60 + DRYNESS FRACTION <-> AT T,H FUNCTION F60D08(T,H) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YP,RL,RG) IF (RL.EQ.RG) GOTO 999 HD=REAL(G13D08(RL,YT,YP)) HDD=REAL(G13D08(RG,YT,YP)) IF (H.LT.HD .OR. H.GT.HDD) GOTO 999 F60D08=(H-HD)/(HDD-HD) RETURN 999 F60D08=-1.0E+20 RETURN END C F61 + DRYNESS FRACTION <-> AT T,S FUNCTION F61D08(T,S) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YP,RL,RG) IF (RL.EQ.RG) GOTO 999 SD=REAL(G15D08(RL,YT)) SDD=REAL(G15D08(RG,YT)) IF (S.LT.SD .OR. S.GT.SDD) GOTO 999 F61D08=(S-SD)/(SDD-SD) RETURN 999 F61D08=-1.0E+20 RETURN END C F62 + DRYNESS FRACTION <-> AT T,U FUNCTION F62D08(T,U) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YP,RL,RG) IF (RL.EQ.RG) GOTO 999 UD=REAL(G12D08(RL,YT)) UDD=REAL(G12D08(RG,YT)) IF (U.LT.UD .OR. U.GT.UDD) GOTO 999 F62D08=(U-UD)/(UDD-UD) RETURN 999 F62D08=-1.0E+20 RETURN END C F63 + DRYNESS FRACTION <-> AT T,V FUNCTION F63D08(T,V) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YP,RL,RG) IF (RL.EQ.RG) GOTO 999 VL=1.0E+00/(REAL(RL)) VG=1.0E+00/(REAL(RG)) IF (V.LT.VL .OR. V.GT.VG) GOTO 999 F63D08=(V-VL)/(VG-VL) RETURN 999 F63D08=-1.0E+20 RETURN END C F64 + TEMPERATURE AT P AND H FUNCTION F64D08(P,H) DOUBLE PRECISION PP,HH,TT,RR,SS,UU PP=DBLE(P)*1.0D+05 HH=DBLE(H) CALL S3D08(PP,HH,TT,RR,SS,UU) T=REAL(TT) IF (T.GE.-1.0) THEN F64D08=T-273.15 ELSE F64D08=T ENDIF RETURN END C F65 + TEMPERATURE AT P AND S FUNCTION F65D08(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P)*1.0D+05 SS=DBLE(S) CALL S4D08(PP,SS,TT,RR,HH,UU) T=REAL(TT) IF (T.GE.-1.0) THEN F65D08=T-273.15 ELSE F65D08=T ENDIF RETURN END C F70 + TEMPERATURE AT P AND V FUNCTION F70D08(P,V) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P)*1.0D+05 YR=1.0D+00/(DBLE(V)) T=REAL(G17D08(YR,YP)) IF (T.GE.-1.0) THEN F70D08=T-273.15 ELSE F70D08=T ENDIF RETURN END C F71 + H AT P AND S FUNCTION F71D08(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P)*1.0D+05 SS=DBLE(S) CALL S4D08(PP,SS,TT,RR,HH,UU) F71D08=REAL(HH) RETURN END C F76 + CV OF SATURATED VAPOUR AT P FUNCTION F76D08(P) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (P.LT.2.2502 .OR. P.GT.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YTS,RL,RG) F76D08=REAL(G10D08(RG,YTS)) RETURN 999 F76D08=-1.0E+20 RETURN END C F77 + CV AT P AND T FUNCTION F77D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F77D08=REAL(G10D08(YR,YT)) RETURN ENDIF ENDIF F77D08=-1.0E+20 RETURN END C F78 + CV OF SATURATED VAPOUR AT T FUNCTION F78D08(T) IMPLICIT DOUBLE PRECISION (G,R,Y) IF (T.LT.-50.8 .OR. T.GT.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,RL,RG) F78D08=REAL(G10D08(RG,YT)) RETURN 999 F78D08=-1.0E+20 RETURN END C F79 + U AT P AND S FUNCTION F79D08(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P)*1.0D+05 SS=DBLE(S) CALL S4D08(PP,SS,TT,RR,HH,UU) F79D08=REAL(UU) RETURN END C F80 + V AT P AND S FUNCTION F80D08(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P)*1.0D+05 SS=DBLE(S) CALL S4D08(PP,SS,TT,RR,HH,UU) IF (RR.GE.0.0) THEN F80D08=1.0E+00/REAL(RR) ELSE F80D08=REAL(RR) ENDIF RETURN END C F81 + PR<-> AT P AND T FUNCTION F81D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) CHARACTER FLUID*19 DOUBLE PRECISION AMYU,ALUM,TK,A1,B1,C1,D1,A2,B2,C2,D2 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA A1,B1,C1,D1 1/0.4420776D+00,-2.360078D+02,1.616337D+04,3.112D+00/ DATA A2,B2,C2,D2 1/0.5145973D+00,-1.901002D+02,1.050020D+04,2.618D+00/ DATA FLUID/'SULFUR HEXAFLUORIDE'/ IF (MESS.NE.0) THEN DP=ABS(P/1.01325-1.0) IF (DP.GT.2.0E-02) THEN WRITE(6,100) FLUID 100 FORMAT(1H ,5X,'**** WARNING : PRPT(P,T) IS ', & 'PRANDTL NUMBER AT ORDINARY PRESSURE', & '(1.01325 BAR) FOR ',A19,' ****') ENDIF ENDIF TK=DBLE(T)+273.15D+00 IF (TK.GE.298.15D+00 .AND. TK.LE.373.15) THEN IF (TK.LE.302.2D+00) THEN AMYU=A1*DLOG(TK)+B1/TK+C1/TK/TK+D1 ELSE AMYU=A2*DLOG(TK)+B2/TK+C2/TK/TK+D2 ENDIF AMYU=DEXP(AMYU)*1.0D-07 YP=1.01325D+05 YR=G5D08(YP,TK) YCP=G11D08(YR,TK) ALUM=G20D08(YR,TK) F81D08=REAL(YCP*AMYU/ALUM) ELSE F81D08=-1.0E+20 ENDIF RETURN END C F82 + ADIABATIC EXPONENT<-> AT P AND T FUNCTION F82D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F82D08=REAL(G16D08(YR,YT,YP)) RETURN ENDIF ENDIF F82D08=-1.0E+20 RETURN END C F83 + SPEED OF SOUND AT P AND T FUNCTION F83D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F83D08=REAL(G14D08(YR,YT)) RETURN ENDIF ENDIF F83D08=-1.0E+20 RETURN END C F90 + BSPT<1/PA> AT P AND T FUNCTION F90D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) SS=REAL(G14D08(YR,YT)) VV=1.0E+00/(REAL(YR)) F90D08=VV/SS**2 RETURN ENDIF ENDIF F90D08=-1.0E+20 RETURN END C F91 + BTPT<1/PA> AT P AND T FUNCTION F91D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) DATA YRCR /728.51D+00/ IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) IF (YR.NE.YRCR) THEN DPDR=REAL(G2D08(YR,YT)) F91D08=1.0E+00/REAL(YR)/DPDR RETURN ENDIF ENDIF ENDIF F91D08=-1.0E+20 RETURN END C F92 + BPPT<1/K> AT P AND T FUNCTION F92D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) DATA YRCR /728.51D+00/ IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) IF (YR.NE.YRCR) THEN F92D08=REAL(G3D08(YR,YT)/YR/G2D08(YR,YT)) RETURN ENDIF ENDIF ENDIF F92D08=-1.0E+20 RETURN END C F93 + BVPT<1/K> AT P AND T FUNCTION F93D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) F93D08=REAL(G3D08(YR,YT)/YP) RETURN ENDIF ENDIF F93D08=-1.0E+20 RETURN END C F94 + AJTPT AT P AND T FUNCTION F94D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) DATA YRCR /728.51D+00/ IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) IF (YR.NE.YRCR) THEN YY=YT*G3D08(YR,YT)/YR/G2D08(YR,YT)-1.0D+00 DPDTDR=REAL(YY) F94D08=REAL(YY/(YR*G11D08(YR,YT))) ELSE F94D08=1.0E+00/REAL(G3D08(YR,YT)) ENDIF RETURN ENDIF ENDIF F94D08=-1.0E+20 RETURN END C F95 + RATIO OF SPECIFIC HEATS AT P AND T FUNCTION F95D08(P,T) IMPLICIT DOUBLE PRECISION (G,Y) DATA YRCR /728.51D+00/ IF (T.GE.-50.8 .AND. T.LE.226.85) THEN IF (P.GE.0.01 .AND. P.LE.500.) THEN YP=DBLE(P)*1.0D+05 YT=DBLE(T+273.15) YR=G5D08(YP,YT) IF (YR.NE.YRCR) THEN F95D08=REAL(G11D08(YR,YT)/G10D08(YR,YT)) RETURN ENDIF ENDIF ENDIF F95D08=-1.0E+20 RETURN END C F96 + RATIO OF SPECIFIC HEATS OF SATURATED VAPOUR AT P FUNCTION F96D08(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.2.2502 .OR. P.GE.37.641) GOTO 999 YP=DBLE(P)*1.0D+05 CALL S2D08(YP,YT,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 F96D08=REAL(G11D08(YRG,YT)/G10D08(YRG,YT)) RETURN 999 F96D08=-1.0E+20 RETURN END C F97 + RATIO OF SPECIFIC HEATS OF SATURATED VAPOUR AT T FUNCTION F97D08(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-50.8 .OR. T.GE.45.598) GOTO 999 YT=DBLE(T+273.15) CALL S1D08(YT,YPS,YRL,YRG) IF (YRL.EQ.YRG) GOTO 999 F97D08=REAL(G11D08(YRG,YT)/G10D08(YRG,YT)) RETURN 999 F97D08=-1.0E+20 RETURN END C F98 + PSEUDO BOILING POINT AT P FUNCTION F98D08(P) DIMENSION T(2),C(2),TL(3),TR(3),CL(3),CR(3) P1=F21D08('P') PP=ABS((P-P1)/P1) T1=F21D08('T') IF (PP.LT.1.0E-5) THEN F98D08=T1 RETURN ENDIF IF (P.LT.P1.OR.P.GT.200.001D00) THEN F98D08=-1.0E+20 RETURN ENDIF T2=0.85*T1 P2=F30D08(T2) TM0=T1+(T1-T2)*(P-P1)/(P1-P2) C-----TM0 KINJICHI TC=T1 T(1)=TM0 150 EPS=1.0E-6 DEL=T1*0.05E00 IREP=0 IREM=5000 KCONT=0 ICONT=0 C(1)=F18D08(P,T(1)) T(2)=T(1)-DEL C(2)=F18D08(P,T(2)) 1000 RINC=C(2)-C(1) IF(RINC.GT.0.3)THEN GOTO 1500 ELSE T(2)=T(1) C(2)=C(1) T(1)=T(1)-DEL C(1)=F18D08(P,T(1)) GOTO 1000 ENDIF 1500 C(1)=-C(1) C(2)=-C(2) 2000 IREP=IREP+1 IF(IREP.GT.IREM) GO TO 8000 TT=T(2)+1.3*(T(2)-T(1)) CC=-F18D08(P,TT) 3000 CONV=ABS((CC-C(2))/CC) IF(CONV.LT.EPS) THEN F98D08=TT RETURN ENDIF 4000 DEC=C(1)-CC ICONT=ICONT+1 IF(DEC.GE.0.0) THEN T(1)=TT C(1)=CC ELSE IF (ICONT.GT.5) GO TO 6000 TT=(TT+T(2))*0.5 CC=-F18D08(P,TT) GOTO 4000 ENDIF 5000 DEC=C(1)-C(2) IF(DEC.LT.0.0) THEN TT=T(1) CC=C(1) T(1)=T(2) C(1)=C(2) T(2)=TT C(2)=CC ENDIF GOTO 2000 6000 TA=T(1) TB=TT IF (TB.LT.TA) THEN TA=TT TB=T(1) ENDIF TC=TA+0.5*(TB-TA) CA=F18D08(P,TA) CB=F18D08(P,TB) 6050 KCONT=KCONT+1 IF (KCONT.GT.IREM) GO TO 8000 DELT=ABS((TA-TB)/TA) IF (DELT.LT.EPS) GO TO 7000 CC=F18D08(P,TC) DTA=(TC-TA)*0.3 TL(1)=TA TL(2)=TC-DTA TL(3)=TC DTB=(TB-TC)*0.3 TR(1)=TC TR(2)=TC+DTB TR(3)=TB CL(1)=CA CL(3)=CC CR(1)=CC CR(3)=CB CL(2)=F18D08(P,TL(2)) CR(2)=F18D08(P,TR(2)) CMXL=CL(1) ML=1 DO 6120 I=2,3 IF(CL(I).GT.CMXL) THEN CMXL=CL(I) ML=I ENDIF 6120 CONTINUE CMXR=CR(1) MR=1 DO 6130 I=2,3 IF(CR(I).GT.CMXR) THEN CMXR=CR(I) MR=I ENDIF 6130 CONTINUE IF(CMXL.GT.CMXR) THEN IF(ML.EQ.1) THEN TA=TL(1)-DTA CA=F18D08(P,TA) ELSE TA=TL(ML-1) CA=CL(ML-1) ENDIF IF(ML.EQ.3) THEN TB=TR(2) CB=CR(2) ELSE TB=TL(ML+1) CB=CL(ML+1) ENDIF TC=TL(ML) CC=CL(ML) ELSE IF(MR.EQ.1) THEN TA=TL(2) CA=CL(2) ELSE TA=TR(MR-1) CA=CR(MR-1) ENDIF IF(MR.EQ.3) THEN TB=TR(3)+DTB CB=F18D08(P,TB) ELSE TB=TR(MR+1) CB=CR(MR+1) ENDIF 6135 TC=TR(MR) CC=CR(MR) ENDIF GO TO 6050 7000 F98D08=TC RETURN 8000 F98D08=-1.0E+10 RETURN END C G01 ************************************ C * THE EQUATION OF STATE P(RO,TK) * C ************************************ C * GCU: UNIVERSAL GAS CONSTANT * C * 8.31433D+03 [J/(KMOL*K] * C * AM : MOLECULER WEIGHT * C * 146.05D+00 [KG/KMOL] * C ************************************ C * G1D08: PRESSURE [PA] * C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C ************************************ FUNCTION G1D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A21,A22,A23,A31,A32,A33,A41,A42,A43,A51,A52,A53 1 / 5.4820D-02, -3.5874D+01, -1.1443D+06, 2 -1.64315D-04, 1.00787D-01, -3.03945D+03, 3 6.674565D-07,-3.714493D-04, 1.573237D+01, 4 -9.112486D-10, 4.8984006D-07,-1.8778235D-02/ DATA A60,A61,A62,A63,A71,A72,A73,A81,A82,A83 1 /-3.4941D-17, 2 7.3006586D-13,-3.6544374D-10, 1.0840107D-05, 3 -2.707784D-16, 1.3897509D-13,-3.388251D-09, 4 3.884286D-20, -2.045054D-17, 4.666427D-13/ DATA B1,B2,B3,B4 1 /-1.126D+02,-5.176D-04,7.0D-06,-7.0D-06/ DATA GCU,AM/8.31433D+03,146.05D+00/ TN2=1.0D+00/(TK*TK) R2=RO*RO R3=R2*RO R4=R3*RO R5=R4*RO R6=R5*RO R7=R6*RO R8=R7*RO P1=GCU/AM*TK*RO P2=(A21*TK+A22+A23*TN2)*R2 P3=(A31*TK+A32+A33*TN2)*R3 P4=(A41*TK+A42+A43*TN2)*R4 P5=(A51*TK+A52+A53*TN2)*R5 P6=(A60*TK**2+A61*TK+A62+A63*TN2)*R6 P7=(A71*TK+A72+A73*TN2)*R7 P8=(A81*TK+A82+A83*TN2)*R8 PE=(B1*R3+B2*R5)*TN2*(1.0D+00+B3*R2)*DEXP(B4*R2) G1D08=P1+P2+P3+P4+P5+P6+P7+P8+PE RETURN END C G02 ************************************ C * DPDRO(RO,TK) [PA/(KG/M**3)] * C ************************************ C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C ************************************ FUNCTION G2D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A21,A22,A23,A31,A32,A33,A41,A42,A43,A51,A52,A53 1 / 5.4820D-02, -3.5874D+01, -1.1443D+06, 2 -1.64315D-04, 1.00787D-01, -3.03945D+03, 3 6.674565D-07,-3.714493D-04, 1.573237D+01, 4 -9.112486D-10, 4.8984006D-07,-1.8778235D-02/ DATA A60,A61,A62,A63,A71,A72,A73,A81,A82,A83 1 /-3.4941D-17, 2 7.3006586D-13,-3.6544374D-10, 1.0840107D-05, 3 -2.707784D-16, 1.3897509D-13,-3.388251D-09, 4 3.884286D-20, -2.045054D-17, 4.666427D-13/ DATA B1,B2,B3,B4 1 /-1.126D+02,-5.176D-04,7.0D-06,-7.0D-06/ DATA GCU,AM/8.31433D+03,146.05D+00/ TN2=1.0D+00/(TK*TK) R2=RO*RO R3=R2*RO R4=R3*RO R5=R4*RO R6=R5*RO R7=R6*RO R8=R7*RO DP1=GCU/AM*TK DP2=(A21*TK+A22+A23*TN2)*2*RO DP3=(A31*TK+A32+A33*TN2)*3*R2 DP4=(A41*TK+A42+A43*TN2)*4*R3 DP5=(A51*TK+A52+A53*TN2)*5*R4 DP6=(A60*TK**2+A61*TK+A62+A63*TN2)*6*R5 DP7=(A71*TK+A72+A73*TN2)*7*R6 DP8=(A81*TK+A82+A83*TN2)*8*R7 DPE=(3*B1+(5*B2+3*B1*B3)*R2+(5*B2-2*B1*B3)*B3*R4 1 -2*B2*B3**2*R6)*R2*DEXP(B4*R2)*TN2 G2D08=DP1+DP2+DP3+DP4+DP5+DP6+DP7+DP8+DPE RETURN END C G03 ************************************ C * DPDTK(RO,TK) [PA/K] * C ************************************ C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C ************************************ FUNCTION G3D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A21,A23,A31,A33,A41,A43,A51,A53 1 / 5.4820D-02, -1.1443D+06, 2 -1.64315D-04, -3.03945D+03, 3 6.674565D-07, 1.573237D+01, 4 -9.112486D-10,-1.8778235D-02/ DATA A60,A61,A63,A71,A73,A81,A83 1 /-3.4941D-17, 2 7.3006586D-13, 1.0840107D-05, 3 -2.707784D-16, -3.388251D-09, 4 3.884286D-20, 4.666427D-13/ DATA B1,B2,B3,B4 1 /-1.126D+02,-5.176D-04,7.0D-06,-7.0D-06/ DATA GCU,AM/8.31433D+03,146.05D+00/ TN23=2.0D+00/(TK*TK*TK) R2=RO*RO R3=R2*RO R4=R3*RO R5=R4*RO R6=R5*RO R7=R6*RO R8=R7*RO DT1=GCU/AM*RO DT2=(A21-A23*TN23)*R2 DT3=(A31-A33*TN23)*R3 DT4=(A41-A43*TN23)*R4 DT5=(A51-A53*TN23)*R5 DT6=(2*A60*TK+A61-A63*TN23)*R6 DT7=(A71-A73*TN23)*R7 DT8=(A81-A83*TN23)*R8 DTE=(B1*R3+B2*R5)*(1.0D+00+B3*R2)*DEXP(B4*R2)*TN23 G3D08=DT1+DT2+DT3+DT4+DT5+DT6+DT7+DT8-DTE RETURN END C G05 ********************************* C * DENSITY [KG/M**3] * C ********************************* C * PP : PRESSURE [PA] * C * TK : TEMPERATURE [K] * C ********************************* FUNCTION G5D08(PP,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,TKCR,RCR /3.7641D+06,318.748D+00,728.51D+00/ DPP=DABS(1.0D+00-PP/PCR) IF (DPP.LT.1.0D-05) THEN DTK=DABS(1.0D+00-TK/TKCR) IF (DTK.LT.1.0D-05) THEN G5D08=RCR RETURN ENDIF ENDIF IF (TK.LE.TKCR) THEN CALL S1D08(TK,PS,RL,RV) IF (PP.GT.PS) THEN RMAX=3000.0D0 RMIN=RL ELSE RMAX=RV RMIN=1.0D-04 ENDIF ELSE IF (PP.GE.PCR) THEN RMAX=3000.0D0 RMIN=1.0D-04 ELSE CALL S2D08(PP,TS,RL,RV) RMAX=RV RMIN=1.0D-4 ENDIF ENDIF EPS1=1.0D-01 RST1=G6D08(RMAX,RMIN,PP,TK,EPS1) G5D08=G7D08(PP,TK,RST1) RETURN END C G06 ************************************ C * DETERMINATION OF INITIAL VALUE * C * FOR R(P,T) * C * RMAX:DENSITY(MAX) [KG/M**3] * C * RMIN:DENSITY(MIN) [KG/M**3] * C * P :PRESSURE [PA] * C * T :TEMPERATURE [K] * C ************************************ FUNCTION G6D08(RMAX,RMIN,P,T,EPS) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DZERO=0.0D+00 ILOOP=0 RA=RMAX RB=RMIN PA=G1D08(RA,T) PB=G1D08(RB,T) 10 ILOOP=ILOOP+1 IF (ILOOP.LE.10000) THEN DPA=P-PA DPB=P-PB DPAB=PA-PB RC=RB+(RA-RB)*0.5D+00 PC=G1D08(RC,T) IF (DABS(RA-RB)/RB.LT.EPS) THEN G6D08=RC RETURN ELSE DPC=P-PC IF (DPA*DPC.Lt.DZERO .AND. DPB*DPC.GT.DZERO) THEN RB=RC PB=PC ELSEIF (DPA*DPC.GT.DZERO .AND. DPB*DPC.Lt.DZERO) THEN RA=RC PA=PC ELSE RA=1.1*RA RB=0.9*RB PA=G1D08(RA,T) PB=G1D08(RB,T) ENDIF ENDIF ELSE G6D08=-1.0E+10 RETURN ENDIF GOTO 10 END C G07 *********************************** C * RPT :DENSITY [KG/M**3] * C * BY NEWTON-METHOD * C * P :PRESSURE [PA] * C * TK :TEMPERATURE [K] * C * R1 :INITIAL VALUE [KG/M**3] * C *********************************** FUNCTION G7D08(P,TK,R1) IMPLICIT DOUBLE PRECISION (A-H,O-Z) R=R1 ILOOP=0 10 ILOOP=ILOOP+1 IF (ILOOP.LT.10000) THEN PD=G1D08(R,TK) DPDRD=G2D08(R,TK) DR=(P-PD)/DPDRD IF (DABS(DR/R).LT.1D-7) THEN G7D08=R+DR RETURN ELSE R=R+DR ENDIF ELSE G7D08=-1D10 RETURN ENDIF GOTO 10 END C S01 ********************************** C * SATURATED PROPERTIES AT TK * C * TK: TEMPERATURE [K] * C * PS:PRESSURE [PA] * C * RL:DENSITY(LIQUID) [KG/M**3] * C * RV:DENSITY(VAPOR) [KG/M**3] * C ********************************** SUBROUTINE S1D08(TK,PS,RL,RV) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,TKCR,RCR /3.7641D+06,318.748D+00,728.51D+00/ DTK=DABS(1.0D+00-TK/TKCR) IF (DTK.LT.1.0D-05) THEN PS=PCR RL=RCR RV=RCR RETURN ENDIF C *** APPROXIMATION EQUATIONS FOR SATURATED STATE DT=1.0D+00-TK/318.70D+00 PS1=-7.2412D+00*DT+2.9633D+00*(DT**6)**0.25D+00 1 -2.9218D+00*DT**2 PS1=318.70D+00/TK*PS1 PS1=3.76D+06*DEXP(PS1) IF (TK.LT.318.70D+00) THEN RL1=1.0D+00+1.9872D+00*DT**0.342D+00 1 +6.151D-01*DT**0.87D+00 RL1=730.0D+00*RL1 ELSE RL1=730D0-(730D0-728.51D0)*(TK-318.7D0)/0.048D+00 ENDIF DT=1.0D+00-TK/318.748D+00 IF (TK.LT.245D+00) THEN YY=-1.2740512D+00-16.028449D+00*DT**1.6D+00 ELSEIF (TK.LT.270D+00) THEN YY=-0.91509710D+00-12.738876D+00*DT**1.3D+00 ELSEIF (TK.LT.290D+00) THEN YY=-0.56809102D+00-9.5117715D+00*DT**1.0D+00 ELSEIF (TK.LT.310D+00) THEN YY=-0.30035944D+00-6.8318387D+00*DT**0.75D+00 ELSE YY=-0.17026184D-01-6.6550823D+00*DT**0.60D+00 ENDIF RV1=728.51D+00*DEXP(YY) C *** APPROXIMATION END *** ILOOP=0 10 ILOOP=ILOOP+1 RV=G7D08(PS1,TK,RV1) PS=G8D08(TK,RL1,RV) IF (TK.LT.318.7D+00) THEN RL=G7D08(PS,TK,RL1) ELSE RL=G6D08(790D+00,728.51D+00,PS,TK,1.0D-05) ENDIF IF (DABS(PS/PS1-1D0).LT.1D-7) THEN RETURN ELSE PS1=PS RL1=RL RV1=RV ENDIF GOTO 10 END C G08 *********************************** C * PRESSURE BY GIBBS CONDITION * C * PRT: PRESSURE [PA] * C * RO : DENSITY [KG/M**3] * C * T : TEMPERATURE [K] * C *********************************** FUNCTION G8D08(TK,RL,RV) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SS=G9D08(RL,TK)-G9D08(RV,TK) G8D08=RV*RL/(RL-RV)*SS RETURN END C G09 ********************************** C * INTEGRAL OF P/RO**2 * C * FOR THE EQUATION OF STATE * C ********************************** C * RO : DENSITY [KG/M**3] * C * T : TEMPERATURE [K] * C ********************************** FUNCTION G9D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A21,A22,A23,A31,A32,A33,A41,A42,A43,A51,A52,A53 1 / 5.4820D-02, -3.5874D+01, -1.1443D+06, 2 -1.64315D-04, 1.00787D-01, -3.03945D+03, 3 6.674565D-07,-3.714493D-04, 1.573237D+01, 4 -9.112486D-10, 4.8984006D-07,-1.8778235D-02/ DATA A60,A61,A62,A63,A71,A72,A73,A81,A82,A83 1 /-3.4941D-17, 2 7.3006586D-13,-3.6544374D-10, 1.0840107D-05, 3 -2.707784D-16, 1.3897509D-13,-3.388251D-09, 4 3.884286D-20, -2.045054D-17, 4.666427D-13/ DATA B1,B2,B3,B4 1 /-1.126D+02,-5.176D-04,7.0D-06,-7.0D-06/ DATA GCU,AM/8.31433D+03,146.05D+00/ TN2=1.0D+00/(TK*TK) R2=RO*RO R3=R2*RO R4=R3*RO R5=R4*RO R6=R5*RO R7=R6*RO P1=GCU/AM*TK*DLOG(RO) P2=(A21*TK+A22+A23*TN2)*RO P3=(A31*TK+A32+A33*TN2)*R2/2.0D+00 P4=(A41*TK+A42+A43*TN2)*R3/3.0D+00 P5=(A51*TK+A52+A53*TN2)*R4/4.0D+00 P6=(A60*TK**2+A61*TK+A62+A63*TN2)*R5/5.0D+00 P7=(A71*TK+A72+A73*TN2)*R6/6.0D+00 P8=(A81*TK+A82+A83*TN2)*R7/7.0D+00 PE1=B1/B4 PE2=(B2+B1*B3)/B4**2*(B4*R2-1.0D+00) PE3=B2*B3/B4**3*(B4**2*R4-2*B4*R2+2.0D+00) G9D08=P1+P2+P3+P4+P5+P6+P7+P8 1 +0.5D+00*TN2*(PE1+PE2+PE3)*DEXP(B4*R2) RETURN END C G10 ************************************ C * CVRT(RO,TK) * C ************************************ C * G10D08: ISOCORIC SPECIFIC HEAT * C * [J/(KG*K)] * C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C ************************************ FUNCTION G10D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A23,A33,A43,A53,A60,A63,A73,A83 1 /-1.1443D+06,-3.03945D+03, 1.573237D+01,-1.8778235D-02, 2 -3.4941D-17, 1.0840107D-05,-3.388251D-09, 4.666427D-13/ DATA B1,B2,B3,B4 /-1.126D+02,-5.176D-04,7.0D-06,-7.0D-06/ DATA C1,C2,C3 /-1.2386D+07, 1.13351D+05, 8.6618D+01/ DATA GCU,AM /8.31433D+03,146.05D+00/ TN3=1.0D+00/(TK*TK*TK) C67=6.0D+00/7.0D+00 R2=RO*RO R3=R2*RO R4=R3*RO R5=R4*RO R6=R5*RO R7=R6*RO B4RO=B4*R2 TN3B4=1.0D+00/(TK*B4)**3 DC2=6*A23*TN3*RO DC3=3*A33*TN3*R2 DC4=2*A43*TN3*R3 DC5=1.5D+00*A53*TN3*R4 DC6=(0.4D+00*A60*TK+1.2D+00*A63*TN3)*R5 DC7=A73*TN3*R6 DC8=C67*A83*TN3*R7 DCE1=B1*B4**2+B4*(B2+B1*B3)*(B4RO-1.0D+00) DCE1=DCE1+B2*B3*(B4RO**2-2*B4RO+2.0D+00) DCE2=B1*B4**2-B4*(B2+B1*B3)+B2*B3*2.0D+00 DCE=3*TN3B4*(DCE2-DCE1*DEXP(B4RO)) CVEQ=DCE-(DC2+DC3+DC4+DC5+DC6+DC7+DC8) CPID=(C1/TK+C2+C3*TK)/AM CVID=CPID-GCU/AM G10D08=CVEQ+CVID RETURN END C G11 ************************************ C * CPRT(RO,TK) * C ************************************ C * G11D08: ISOBARIC SPECIFIC HEAT * C * [J/(KG*K)] * C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C ************************************ FUNCTION G11D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CV=G10D08(RO,TK) DPDT=G3D08(RO,TK) DPDR=G2D08(RO,TK) G11D08=CV+TK*DPDT**2/RO**2/DPDR RETURN END C G12 ********************************** C * INTERNAL ENERGY * C ********************************** C * RO : DENSITY [KG/M**3] * C * T : TEMPERATURE [K] * C ********************************** FUNCTION G12D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A21,A22,A23,A31,A32,A33,A41,A42,A43,A51,A52,A53 1 / 5.4820D-02, -3.5874D+01, -1.1443D+06, 2 -1.64315D-04, 1.00787D-01, -3.03945D+03, 3 6.674565D-07,-3.714493D-04, 1.573237D+01, 4 -9.112486D-10, 4.8984006D-07,-1.8778235D-02/ DATA A60,A61,A62,A63,A71,A72,A73,A81,A82,A83 1 /-3.4941D-17, 2 7.3006586D-13,-3.6544374D-10, 1.0840107D-05, 3 -2.707784D-16, 1.3897509D-13,-3.388251D-09, 4 3.884286D-20, -2.045054D-17, 4.666427D-13/ DATA B1,B2,B3,B4 1 /-1.126D+02,-5.176D-04,7.0D-06,-7.0D-06/ DATA C1,C2,C3 /-1.2386D+07, 1.13351D+05, 8.6618D+01/ DATA GCU,AM/8.31433D+03,146.05D+00/ DATA TA/298.15D+00/ TN2=1.0D+00/(TK*TK) R2=RO*RO R3=R2*RO R4=R3*RO R5=R4*RO R6=R5*RO R7=R6*RO P1=GCU/AM*TK P2=(A22+3*A23*TN2)*RO P3=(A32+3*A33*TN2)*R2/2.0D+00 P4=(A42+3*A43*TN2)*R3/3.0D+00 P5=(A52+3*A53*TN2)*R4/4.0D+00 P6=(A62+3*A63*TN2-A60*TK**2)*R5/5.0D+00 P7=(A72+3*A73*TN2)*R6/6.0D+00 P8=(A82+3*A83*TN2)*R7/7.0D+00 PE1=B1/B4 PE2=(B2+B1*B3)/B4**2*(B4*R2-1.0D+00) PE0=PE1-(B2+B1*B3)/B4**2 PE3=B2*B3/B4**3*(B4**2*R4-2*B4*R2+2.0D+00) PE0=PE0+2*B2*B3/B4**3 UU=P2+P3+P4+P5+P6+P7+P8 1 +1.5D+00*TN2*((PE1+PE2+PE3)*DEXP(B4*R2)-PE0) HIDTK=C1*DLOG(TK)+C2*TK+C3*TK*TK/2.0D+00 HIDTA=C1*DLOG(TA)+C2*TA+C3*TA*TA/2.0D+00 HID=(HIDTK-HIDTA)/AM UID=HID-GCU/AM*TK G12D08=UU+UID RETURN END C G13 ********************************** C * ENTHALPY [J/KG] * C ********************************** C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C * PP : PRESSURE [PA] * C ********************************** FUNCTION G13D08(RO,TK,PP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) U=G12D08(RO,TK) G13D08=U+PP/RO RETURN END C G15 ********************************** C * ENTROPY [J/(KG*K)] * C ********************************** C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C ********************************** FUNCTION G15D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A21,A23,A31,A33,A41,A43,A51,A53 1 / 5.4820D-02, -1.1443D+06, 2 -1.64315D-04, -3.03945D+03, 3 6.674565D-07, 1.573237D+01, 4 -9.112486D-10,-1.8778235D-02/ DATA A60,A61,A63,A71,A73,A81,A83 1 /-3.4941D-17, 2 7.3006586D-13, 1.0840107D-05, 3 -2.707784D-16, -3.388251D-09, 4 3.884286D-20, 4.666427D-13/ DATA B1,B2,B3,B4 1 /-1.126D+02,-5.176D-04,7.0D-06,-7.0D-06/ DATA C1,C2,C3 /-1.2386D+07, 1.13351D+05, 8.6618D+01/ DATA GCU,AM/8.31433D+03,146.05D+00/ DATA TA,PA/298.15D+00,1.01325D+05/ TN23=2.0D+00/(TK*TK*TK) R2=RO*RO R3=R2*RO R4=R3*RO R5=R4*RO R6=R5*RO R7=R6*RO R8=R7*RO DS1=GCU/AM*RO DS2=(A21-A23*TN23)*RO DS3=(A31-A33*TN23)*R2/2.0D+00 DS4=(A41-A43*TN23)*R3/3.0D+00 DS5=(A51-A53*TN23)*R4/4.0D+00 DS6=(2*A60*TK+A61-A63*TN23)*R5/5.0D+00 DS7=(A71-A73*TN23)*R6/6.0D+00 DS8=(A81-A83*TN23)*R7/7.0D+00 PE1=B1/B4 PE2=(B2+B1*B3)/B4**2*(B4*R2-1.0D+00) PE0=PE1-(B2+B1*B3)/B4**2 PE3=B2*B3/B4**3*(B4**2*R4-2*B4*R2+2.0D+00) PE0=PE0+2*B2*B3/B4**3 SS=0.5D+00*TN23*((PE1+PE2+PE3)*DEXP(B4*R2)-PE0) 1 -(DS2+DS3+DS4+DS5+DS6+DS7+DS8) SS=SS-GCU/AM*DLOG(RO*GCU/AM*TK/PA) SIDTK=-C1/TK+C2*DLOG(TK)+C3*TK SIDTA=-C1/TA+C2*DLOG(TA)+C3*TA SID=(SIDTK-SIDTA)/AM G15D08=SS+SID RETURN END C S02 ************************************ C * SATURATED PROPERTIES * C * PP:PRESSURE [PA] * C * TS:TEMPERATURE [K] * C * RL:DENSITY OF LIQUID [KG/M**3]* C * RV:DENSITY OF VAPOR [KG/M**3]* C * SRT: [J/KG*K] * C ************************************ SUBROUTINE S2D08(PP,TS,RL,RV) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,TKCR,RCR /3.7641D+06,318.748D+00,728.51D+00/ DPP=DABS(1.0D+00-PP/PCR) IF (DPP.LT.1.0D-05) THEN TS=TKCR RL=RCR RV=RCR RETURN ENDIF IF (PP.LT.0.3D+06) THEN T1=225D0 ELSEIF (PP.LT.0.7D+06) THEN T1=245D0 ELSEIF (PP.LT.1.3D+06) THEN T1=265D0 ELSEIF (PP.LT.2.2D+06) THEN T1=285D0 ELSEIF (PP.LT.3.1D+06) THEN T1=305D0 ELSEIF (PP.LT.3.5D+06) THEN T1=315D0 ELSEIF (PP.LT.3.7D+06) THEN T1=317D0 ELSEIF (PP.LE.3.7641D+06) THEN T1=318D0 ELSE RETURN ENDIF ILOOP=0 20 ILOOP=ILOOP+1 IF (T1.GT.318.748D0) THEN RETURN ENDIF CALL S1D08(T1,P1,RL,RV) SL=G15D08(RL,T1) SV=G15D08(RV,T1) DPSDT=(SV-SL)/(RL-RV)*RL*RV DT=(PP-P1)/DPSDT IF (DABS(DT/T1).LT.1D-7) THEN TS=T1 RETURN ELSE T1=T1+DT ENDIF GOTO 20 END C G14 ********************************** C * SPEED OF SOUND [M/S] * C ********************************** C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C ********************************** FUNCTION G14D08(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CV=G10D08(RO,TK) DPDT=G3D08(RO,TK) DPDR=G2D08(RO,TK) G14D08=DSQRT(DPDR+TK*(DPDT/RO)**2/CV) RETURN END C G16 ********************************** C * ADIABATIC EXPONENT[M/S] * C ********************************** C * RO : DENSITY [KG/M**3] * C * TK : TEMPERATURE [K] * C * PP : PRESSURE [PA] * C ********************************** FUNCTION G16D08(RO,TK,PP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CV=G10D08(RO,TK) DPDT=G3D08(RO,TK) DPDR=G2D08(RO,TK) WW=DPDR+TK*(DPDT/RO)**2/CV G16D08=WW*RO/PP RETURN END C G04 ********************************** C * SURFACE TENSION [N/M] * C ********************************** C * TK : TEMPERATURE [K] * C ********************************** FUNCTION G4D08(TK) DATA SIG0,EE,TKCRS/54.44E-03,1.289,318.63/ TAU=(TKCRS-TK)/TKCRS IF (TK.LT.318.248) THEN G4D08=SIG0*TAU**EE ELSE G4D08=0.0E+00 ENDIF RETURN END C S03 *** T(P0,H0) R(P0,H0) FROM P(R,T)-P0=0 AND H(R,T)-H0=0 SUBROUTINE S3D08(P,H,T,R,S,U) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,TKCR,RCR /3.7641D+06,318.748D+00,728.51D+00/ IF (P.LT.1.0D+03 .OR. P.GT.50D+06) GOTO 999 HCR=G13D08(RCR,TKCR,PCR) DPCR=DABS(P/PCR-1.0D+00) IF (DPCR.LT.1.0D-05) THEN DHCR=DABS(H/HCR-1.0D+00) IF (DHCR.LT.1.0D-05) THEN T=TKCR R=RCR S=G15D08(R,T) U=G12D08(R,T) RETURN ENDIF ENDIF TMIN=222.35D+00 TMAX=500.00D+00 RMAX=G5D08(P,TMAX) RMIN=G5D08(P,TMIN) HMAX=G13D08(RMAX,TMAX,P) HMIN=G13D08(RMIN,TMIN,P) IF (H.LT.HMIN .OR. H.GT.HMAX) GOTO 999 IF (P.GT.PCR) THEN IF (H.GT.HCR) THEN TA=TMAX RA=RMAX HA=HMAX TB=TKCR RB=RCR HB=HCR ELSE TA=TKCR RA=RCR HA=HCR TB=TMIN RB=RMIN HB=HMIN ENDIF ELSE CALL S2D08(P,T,RL,RG) HG=G13D08(RG,T,P) HL=G13D08(RL,T,P) IF (H.LT.HL) THEN TA=T RA=RL HA=HL TB=TMIN RB=RMIN HB=HMIN ELSEIF (H.LE.HG) THEN VG=1.0D+00/RG VL=1.0D+00/RL X=(H-HL)/(HG-HL) V=VL+X*(VG-VL) R=1D0/V SL=G15D08(RL,T) SG=G15D08(RG,T) S=SL+X*(SG-SL) UL=G12D08(RL,T) UG=G12D08(RG,T) U=UL+X*(UG-UL) RETURN ELSE TA=TMAX RA=RMAX HA=HMAX TB=T RB=RG HB=HG ENDIF ENDIF ILOOP=0 10 DHA=H-HA DHB=H-HB T=TB+(TA-TB)*0.5D+00 R=G5D08(P,T) HC=G13D08(R,T,P) DHC=H-HC IF (DHA*DHC.LE.0.0 .AND. DHB*DHC.GT.0.0) THEN TB=T RB=R HB=HC ELSEIF (DHA*DHC.GT.0.0 .AND. DHB*DHC.LE.0.0) THEN TA=T RA=R HA=HC ENDIF ILOOP=ILOOP+1 IF (ILOOP.EQ.10000) THEN T=-1.0E+10 R=-1.0E+10 S=-1.0E+10 U=-1.0E+10 ELSEIF (DABS((HA-HB)/H).GT.1.0D-07) THEN GOTO 10 ELSE S=G15D08(R,T) U=G12D08(R,T) ENDIF RETURN 999 T=-1.0E+20 R=-1.0E+20 S=-1.0E+20 U=-1.0E+20 RETURN END C S04 *** T(P0,S0) R(P0,S0) FROM P(R,T)-P0=0 AND S(R,T)-S0=0 SUBROUTINE S4D08(P,S,T,R,H,U) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,TKCR,RCR /3.7641D+06,318.748D+00,728.51D+00/ IF (P.LT.1.0D+03 .OR. P.GT.50D+06) GOTO 999 SCR=G15D08(RCR,TKCR) DPCR=DABS(P/PCR-1.0D+00) IF (DPCR.LT.1.0D-05) THEN DSCR=DABS(S/SCR-1.0D+00) IF (DSCR.LT.1.0D-05) THEN T=TKCR R=RCR H=G13D08(R,T,P) U=G12D08(R,T) RETURN ENDIF ENDIF TMIN=222.35D+00 TMAX=500.00D+00 RMAX=G5D08(P,TMAX) RMIN=G5D08(P,TMIN) SMAX=G15D08(RMAX,TMAX) SMIN=G15D08(RMIN,TMIN) IF (S.LT.SMIN .OR. S.GT.SMAX) GOTO 999 IF (P.GT.PCR) THEN IF (S.GT.SCR) THEN TA=TMAX RA=RMAX SA=SMAX TB=TKCR RB=RCR SB=SCR ELSE TA=TKCR RA=RCR SA=SCR TB=TMIN RB=RMIN SB=SMIN ENDIF ELSE CALL S2D08(P,T,RL,RG) SG=G15D08(RG,T) SL=G15D08(RL,T) IF (S.LT.SL) THEN TA=T RA=RL SA=SL TB=TMIN RB=RMIN SB=SMIN ELSEIF (S.LE.SG) THEN VL=1D0/RL VG=1D0/RG X=(S-SL)/(SG-SL) V=VL+X*(VG-VL) R=1D0/V HG=G13D08(RG,T,P) HL=G13D08(RL,T,P) H=HL+X*(HG-HL) UG=G12D08(RG,T) UL=G12D08(RL,T) U=UL+X*(UG-UL) RETURN ELSE TA=TMAX RA=RMAX SA=SMAX TB=T RB=RG SB=SG ENDIF ENDIF ILOOP=0 10 DSA=S-SA DSB=S-SB T=TB+(TA-TB)*0.5D+00 R=G5D08(P,T) SC=G15D08(R,T) DSC=S-SC IF (DSA*DSC.LE.0.0 .AND. DSB*DSC.GT.0.0) THEN TB=T RB=R SB=SC ELSEIF (DSA*DSC.GT.0.0 .AND. DSB*DSC.LE.0.0) THEN TA=T RA=R SA=SC ENDIF ILOOP=ILOOP+1 IF (ILOOP.EQ.10000) THEN T=-1.0E+10 R=-1.0E+10 H=-1.0E+10 U=-1.0E+10 ELSEIF (DABS((SA-SB)/S).GT.1.0D-07) THEN GOTO 10 ELSE H=G13D08(R,T,P) U=G12D08(R,T) ENDIF RETURN 999 T=-1.0E+20 R=-1.0E+20 H=-1.0E+20 U=-1.0E+20 RETURN END C G17 ************************************ C * TRP: TEMPERATURE [K] * C * RO : DENSITY [KG/M**3] * C * PP : PRESSURE [PA] * C ************************************ FUNCTION G17D08(RO,PP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,TKCR,RCR /3.7641D+06,318.748D+00,728.51D+00/ IF (PP.GT.50D+06) GOTO 999 IF (PP.LT.1.0D+03) GOTO 999 DRCR=DABS(RO/RCR-1.0D+00) IF (DRCR.LT.1.0D-05) THEN G17D08=TKCR RETURN ENDIF TMIN=222.35D+00 RMAX=G5D08(PP,TMIN) IF (RO.GT.RMAX) GOTO 999 TMAX=500D+00 RMIN=G5D08(PP,TMAX) IF (RO.LT.RMIN) GOTO 999 IF (PP.LT.PCR) THEN CALL S2D08(PP,TS,RL,RG) IF (RO.GT.RL) THEN T1=TS ELSEIF (RO.GE.RG) THEN G17D08=TS RETURN ELSE T1=G18D08(TMAX,TS,RO,PP) ENDIF ELSE T1=G18D08(TMAX,TMIN,RO,PP) ENDIF G17D08=G19D08(RO,PP,T1) RETURN 999 G17D08=-1.0E+20 RETURN END C G18 ************************************ C * DETERMINATION OF INITIAL VALUE * C * FOR T(RO,P) * C * TMAX:TEMPERATURE(MAX) [K] * C * TMIN:TEMPERATURE(MIN) [K] * C * RO :DENSITY [KG/M**3] * C * PP :PRESSURE [PA] * C ************************************ FUNCTION G18D08(TMAX,TMIN,RO,PP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 TA=TMAX TB=TMIN RA=G5D08(PP,TA) RB=G5D08(PP,TB) 10 ILOOP=ILOOP+1 IF (ILOOP.LE.10000) THEN DRA=RO-RA DRB=RO-RB DRAB=RA-RB T=TB+(TA-TB)*0.5D+00 IF (DABS(TA-TB)/T.LT.1.0D-02) THEN G18D08=T RETURN ELSE RC=G5D08(PP,T) DRC=RO-RC IF (DRA*DRC.LE.0.0 .AND. DRB*DRC.GT.0.0) THEN TB=T RB=RC ELSEIF (DRA*DRC.GT.0.0 .AND. DRB*DRC.LE.0.0) THEN TA=T RA=RC ENDIF ENDIF ELSE G18D08=-1.0E+10 RETURN ENDIF GOTO 10 END C G19 ************************************ C * TRPNEW:TEMPERATURE [K] * C * BY NEWTON-METHOD * C * RO :DENSITY [KG/M**3] * C * PP :PRESSURE [PA] * C * T1 :INITIAL VALUE [K] * C ************************************ FUNCTION G19D08(RO,PP,T1) IMPLICIT DOUBLE PRECISION (A-H,O-Z) TK=T1 ILOOP=0 10 ILOOP=ILOOP+1 IF (ILOOP.LT.10000) THEN P1=G1D08(RO,TK) DPDT=G3D08(RO,TK) DT=(PP-P1)/DPDT IF (DABS(DT/TK).LT.1D-7) THEN G19D08=TK+DT RETURN ELSE TK=TK+DT ENDIF ELSE G19D08=-1.0E+10 RETURN ENDIF GOTO 10 END C G20 ***************************************** C * THERMAL CONDUCTIVITY OF GASEOUS SF6 * C * G20D08: [W/(M*K)] * C * RO: DENSITY [KG/M**3] * C * RD: DENSITY [KG/DM**3] * C * T : TEMPERATURE [K] * C ***************************************** FUNCTION G20D08(RO,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B(4,5) DATA B/ 4.363877D+02,-3.895269D+00, 1.171255D-02,-1.145226D-05, 1 -4.683394D+03, 4.131177D+01,-1.197558D-01, 1.142399D-04, 2 -2.869690D+04, 2.350331D+02,-6.485542D-01, 6.051837D-04, 3 5.099697D+05,-4.332473D+03, 1.228140D+01,-1.161702D-02, 4 -1.175845D+06, 1.003095D+04,-2.851031D+01, 2.699752D-02/ RD=RO*1.0D-03 ALUM=0.0D+00 RR=1.0D+00 DO 20 J=1,5 TT=1.0D+00 DO 10 I=1,4 ALUM=ALUM+B(I,J)*TT*RR TT=TT*T 10 CONTINUE RR=RR*RD 20 CONTINUE G20D08=ALUM*1.0D-03 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