C ***************************** C C * PROPATH VER.7.1 * C C * HYDROGEN VER.2.1 * C C ***************************** 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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(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 S99D02(FUN) WTDD=-1.0E+30 RETURN END C C==================================================================== C------------------------------------------------- F1 = AIPPT REAL FUNCTION AIPPT(P,T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'AIPPT'/ PP=P TT=T CALL S99D02(FNA) AIPPT=-1.0E+30 RETURN END C------------------------------------------------- F94 = AJTPT REAL FUNCTION AJTPT(P,T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'AJTPT'/ PP=P TT=T CALL S99D02(FNAME) AJTPT=-1.0E+30 RETURN END C------------------------------------------------- F2 = ALAPP REAL FUNCTION ALAPP(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALAPP'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F2B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALAPT'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F3B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 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 PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHP'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F4B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- ALHP=FF RETURN END C------------------------------------------------- F5 = ALHT REAL FUNCTION ALHT(T) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHT'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F5B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- ALHT=FF RETURN END C------------------------------------------------- F6 = ALMPD REAL FUNCTION ALMPD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'ALMPD'/ PP=P CALL S99D02(FNA) ALMPD=-1.0E+30 RETURN END C------------------------------------------------- F7 = ALMPDD REAL FUNCTION ALMPDD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'ALMPDD'/ PP=P CALL S99D02(FNA) ALMPDD=-1.0E+30 RETURN END C------------------------------------------------- F8 = ALMPT REAL FUNCTION ALMPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALMPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F8B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- ALMPT=FF RETURN END C------------------------------------------------- F9 = ALMTD REAL FUNCTION ALMTD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'ALMTD'/ TT=T CALL S99D02(FNA) ALMTD=-1.0E+30 RETURN END C------------------------------------------------- F10 = ALMTDD REAL FUNCTION ALMTDD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'ALMTDD'/ TT=T CALL S99D02(FNA) ALMTDD=-1.0E+30 RETURN END C------------------------------------------------- F11 = AMUPD REAL FUNCTION AMUPD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'AMUPD'/ PP=P CALL S99D02(FNA) AMUPD=-1.0E+30 RETURN END C------------------------------------------------- F12 = AMUPDD REAL FUNCTION AMUPDD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'AMUPDD'/ PP=P CALL S99D02(FNA) AMUPDD=-1.0E+30 RETURN END C------------------------------------------------- F13 = AMUPT REAL FUNCTION AMUPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'AMUPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F13B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- AMUPT=FF RETURN END C------------------------------------------------- F14 = AMUTD REAL FUNCTION AMUTD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'AMUTD'/ TT=T CALL S99D02(FNA) AMUTD=-1.0E+30 RETURN END C------------------------------------------------- F15 = AMUTDD REAL FUNCTION AMUTDD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'AMUTDD'/ TT=T CALL S99D02(FNA) AMUTDD=-1.0E+30 RETURN END C------------------------------------------------- F92 = BPPT REAL FUNCTION BPPT(P,T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'BPPT'/ PP=P TT=T CALL S99D02(FNAME) BPPT=-1.0E+30 RETURN END C------------------------------------------------- F90 = BSPT REAL FUNCTION BSPT(P,T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'BSPT'/ PP=P TT=T CALL S99D02(FNAME) BSPT=-1.0E+30 RETURN END C------------------------------------------------- F91 = BTPT REAL FUNCTION BTPT(P,T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'BTPT'/ PP=P TT=T CALL S99D02(FNAME) BTPT=-1.0E+30 RETURN END C------------------------------------------------- F93 = BVPT REAL FUNCTION BVPT(P,T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'BVPT'/ PP=P TT=T CALL S99D02(FNAME) BVPT=-1.0E+30 RETURN END C------------------------------------------------- F16 = CPPD REAL FUNCTION CPPD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'CPPD'/ PP=P CALL S99D02(FNA) CPPD=-1.0E+30 RETURN END C------------------------------------------------- F17 = CPPDD REAL FUNCTION CPPDD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'CPPDD'/ PP=P CALL S99D02(FNA) CPPDD=-1.0E+30 RETURN END C------------------------------------------------- F18 = CPPT REAL FUNCTION CPPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F18B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPPT=FF RETURN END C------------------------------------------------- F19 = CPTD REAL FUNCTION CPTD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'CPTD'/ TT=T CALL S99D02(FNA) CPTD=-1.0E+30 RETURN END C------------------------------------------------- F20 = CPTDD REAL FUNCTION CPTDD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'CPTDD'/ TT=T CALL S99D02(FNA) CPTDD=-1.0E+30 RETURN END C------------------------------------------------- F21 = CRP REAL FUNCTION CRP(A) CHARACTER FUN*6,A*1,FLUID*16 REAL T0K,PBAR,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CRP'/,FLUID/'HYDROGEN'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF C--- FUNCTION CALL --- FF = F21B02(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF (MESS.NE.0) THEN WRITE(6,6010) FUN,FLUID,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A, & ' WHEN A =',A,' ****') END IF FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=FF+T0K ELSE IF(A.EQ.'P') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=FF/PBAR END IF CRP=FF RETURN END C------------------------------------------------- F22 = EPSPT REAL FUNCTION EPSPT(P,T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'EPSPT'/ PP=P TT=T CALL S99D02(FNA) EPSPT=-1.0E+30 RETURN END C------------------------------------------------- F89 = FC C************************************************ C FUNCTION FOR FUNDDAMENTAL CONSTANTS C PROPATH VER.7.1, MAY 8, 1990 C USAGE: B=FC(A) C A, B : CHARACTER TYPE VALIABLES C B='2.016' WHEN A='M' C B='4124.62' WHEN A='R' C************************************************ REAL FUNCTION FC(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'M') THEN FC=2.016 ELSE IF (A.EQ.'R') THEN FC=4124.62 ELSE FC=-1.E+20 IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT FC FOR N-HYDROGEN WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F96 = GAMPDD REAL FUNCTION GAMPDD(P) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'GAMPDD'/ PP=P CALL S99D02(FNAME) GAMPDD=-1.0E+30 RETURN END C------------------------------------------------- F95 = GAMPT REAL FUNCTION GAMPT(P,T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'GAMPT'/ PP=P TT=T CALL S99D02(FNAME) GAMPT=-1.0E+30 RETURN END C------------------------------------------------- F97 = GAMTDD REAL FUNCTION GAMTDD(T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'GAMTDD'/ TT=T CALL S99D02(FNAME) GAMTDD=-1.0E+30 RETURN END C------------------------------------------------- F23 = HPD REAL FUNCTION HPD(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F23B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPD=FF RETURN END C------------------------------------------------- F24 = HPDD REAL FUNCTION HPDD(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F24B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPDD=FF RETURN END C------------------------------------------------- F25 = HPT REAL FUNCTION HPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F25B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPT=FF RETURN END C------------------------------------------------- F26 = HPX REAL FUNCTION HPX(P,X) CHARACTER FUN*6 REAL PBAR,P,X,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F26B02(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F27B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HTD=FF RETURN END C------------------------------------------------- F28 = HTDD REAL FUNCTION HTDD(T) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F28B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HTDD=FF RETURN END C------------------------------------------------- F29 = HTX REAL FUNCTION HTX(T,X) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F29B02(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 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='HYDROGEN' WHEN A='S' C B='H2' WHEN A='C' C B='12.1' WHEN A='V' C************************************************ CHARACTER*20 FUNCTION IDENTF(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'S') THEN IDENTF='HYDROGEN' ELSE IF (A.EQ.'C') THEN IDENTF='H2' ELSE IF (A.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT IDENTF FOR HYDROGEN WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F30 = PST REAL FUNCTION PST(T) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PST'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F30B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PST=FF/PBAR RETURN END C------------------------------------------------- F31 = SIGP REAL FUNCTION SIGP(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SIGP'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F31B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SIGT'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F32B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 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 PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F33B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPD=FF RETURN END C------------------------------------------------- F34 = SPDD REAL FUNCTION SPDD(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F34B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPDD=FF RETURN END C------------------------------------------------- F35 = SPT REAL FUNCTION SPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F35B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPT=FF RETURN END C------------------------------------------------- F36 = SPX REAL FUNCTION SPX(P,X) CHARACTER FUN*6 REAL PBAR,P,X,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F36B02(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F37B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- STD=FF RETURN END C------------------------------------------------- F38 = STDD REAL FUNCTION STDD(T) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F38B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- STDD=FF RETURN END C------------------------------------------------- F39 = STX REAL FUNCTION STX(T,X) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F39B02(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- STX=FF RETURN END C------------------------------------------------- F40 = TSP REAL FUNCTION TSP(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TSP'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F40B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TSP=FF+T0K RETURN END C------------------------------------------------- F41 = TRPL REAL FUNCTION TRPL(A) CHARACTER FUN*6,A*1,FLUID*16 REAL T0K,PBAR,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TRPL'/ ,FLUID/'HYDROGEN'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF C--- FUNCTION CALL --- FF = F41B02(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF(MESS.NE.0) THEN WRITE(6,6010) FUN,FLUID,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A, & ' WHEN A =',A,' ****') ENDIF FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=FF+T0K ELSE IF(A.EQ.'P') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=FF/PBAR END IF TRPL=FF RETURN END C------------------------------------------------- F42 = UPD REAL FUNCTION UPD(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F42B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPD=FF RETURN END C------------------------------------------------- F43 = UPDD REAL FUNCTION UPDD(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F43B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPDD=FF RETURN END C------------------------------------------------- F44 = UPT REAL FUNCTION UPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F44B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPT=FF RETURN END C------------------------------------------------- F45 = UPX REAL FUNCTION UPX(P,X) CHARACTER FUN*6 REAL PBAR,P,X,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F45B02(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F46B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UTD=FF RETURN END C------------------------------------------------- F47 = UTDD REAL FUNCTION UTDD(T) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F47B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UTDD=FF RETURN END C------------------------------------------------- F48 = UTX REAL FUNCTION UTX(T,X) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F48B02(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 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 PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F49B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPD=FF RETURN END C------------------------------------------------- F50 = VPDD REAL FUNCTION VPDD(P) CHARACTER FUN*6 REAL PBAR,P,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F50B02(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPDD=FF RETURN END C------------------------------------------------- F51 = VPT REAL FUNCTION VPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F51B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPT=FF RETURN END C------------------------------------------------- F52 = VPX REAL FUNCTION VPX(P,X) CHARACTER FUN*6 REAL PBAR,P,X,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F52B02(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F53B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VTD=FF RETURN END C------------------------------------------------- F54 = VTDD REAL FUNCTION VTDD(T) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTDD'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F54B02(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VTDD=FF RETURN END C------------------------------------------------- F55 = VTX REAL FUNCTION VTX(T,X) CHARACTER FUN*6 REAL T0K,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTX'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F55B02(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VTX=FF RETURN END C------------------------------------------------- F56 = XPH REAL FUNCTION XPH(P,H) CHARACTER FUN*6 REAL PBAR,P,H,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPH'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F56B02(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 PBAR,P,S,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPS'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F57B02(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 PBAR,P,U,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPU'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F58B02(PI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 PBAR,P,V,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPV'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F59B02(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,H,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTH'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F60B02(TI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,S,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTS'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F61B02(TI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,U,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTU'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F62B02(TI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 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 T0K,T,V,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTV'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF TI=T-T0K C--- FUNCTION CALL --- FF = F63B02(TI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- XTV=FF RETURN END C------------------------------------------------- F64 = TPH REAL FUNCTION TPH(P,H) CHARACTER FUN*6 REAL T0K,PBAR,P,H,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TPH'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F64B02(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TPH=FF+T0K RETURN END C------------------------------------------------- F65 = TPS REAL FUNCTION TPS(P,S) CHARACTER FUN*6 REAL T0K,PBAR,P,S,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TPS'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F65B02(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TPS=FF+T0K RETURN END C------------------------------------------------- F66 = PLDT REAL FUNCTION PLDT(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PLDT'/ TT=T CALL S99D02(FNA) PLDT=-1.0E+30 RETURN END C------------------------------------------------- F68 = PMLT REAL FUNCTION PMLT(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PMLT'/ TT=T CALL S99D02(FNA) PMLT=-1.0E+30 RETURN END C------------------------------------------------- F99 = PSBT REAL FUNCTION PSBT(T) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'PSBT'/ TT=T CALL S99D02(FNAME) PSBT=-1.0E+30 RETURN END C------------------------------------------------- F67 = TLDP REAL FUNCTION TLDP(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'TLDP'/ PP=P CALL S99D02(FNA) TLDP=-1.0E+30 RETURN END C------------------------------------------------- F69 = TMLP REAL FUNCTION TMLP(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'TMLP'/ PP=P CALL S99D02(FNA) TMLP=-1.0E+30 RETURN END C------------------------------------------------- F98 = TPSEUP REAL FUNCTION TPSEUP(P) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'TPSEUP'/ PP=P CALL S99D02(FNAME) TPSEUP=-1.0E+30 RETURN END C------------------------------------------------- F100 = TSBP REAL FUNCTION TSBP(P) CHARACTER FNAME*6 COMMON/UNIT/KPA,MESS DATA FNAME/'TSBP'/ PP=P CALL S99D02(FNAME) TSBP=-1.0E+30 RETURN END C------------------------------------------------- F70 = TPV REAL FUNCTION TPV(P,V) CHARACTER FUN*6 REAL T0K,PBAR,P,V,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TPV'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F70B02(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TPV=FF+T0K RETURN END C------------------------------------------------- F71 = HPS REAL FUNCTION HPS(P,S) CHARACTER FUN*6 REAL PBAR,P,S,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPS'/ C--- SET OF UNIT --- IF((KPA.EQ.1).OR.(KPA.EQ.2)) THEN PBAR=1.0 ELSE PBAR=1.0E-05 END IF PI=P*PBAR C--- FUNCTION CALL --- FF = F71B02(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPS=FF RETURN END C------------------------------------------------- F72 = PSTD REAL FUNCTION PSTD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PSTD'/ TT=T CALL S99D02(FNA) PSTD=-1.0E+30 RETURN END C------------------------------------------------- F73 = PSTDD REAL FUNCTION PSTDD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PSTDD'/ TT=T CALL S99D02(FNA) PSTDD=-1.0E+30 RETURN END C------------------------------------------------- F74 = TSPD REAL FUNCTION TSPD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'TSPD'/ PP=P CALL S99D02(FNA) TSPD=-1.0E+30 RETURN END C------------------------------------------------- F75 = TSPDD REAL FUNCTION TSPDD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'TSPDD'/ PP=P CALL S99D02(FNA) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F76 = CVPDD REAL FUNCTION CVPDD(P) CHARACTER FNA*6 DATA FNA/'CVPDD'/ PP=P CALL S99D02(FNA) CVPDD=-1.0E+30 RETURN END C------------------------------------------------- F77 = CVPT REAL FUNCTION CVPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CVPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F77B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CVPT=FF RETURN END C------------------------------------------------- F78 = CVTDD REAL FUNCTION CVTDD(T) CHARACTER FNA*6 DATA FNA/'CVTDD'/ TT=T CALL S99D02(FNA) CVTDD=-1.0E+30 RETURN END C------------------------------------------------- F79 = UPS REAL FUNCTION UPS(P,S) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'UPS'/ PP=P SS=S CALL S99D02(FNA) UPS=-1.0E+30 RETURN END C------------------------------------------------- F80 = VPS REAL FUNCTION VPS(P,S) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'VPS'/ PP=P SS=S CALL S99D02(FNA) VPS=-1.0E+30 RETURN END C------------------------------------------------- F81 = PRPT REAL FUNCTION PRPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PRPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F81B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- PRPT=FF RETURN END C------------------------------------------------- F82 = AKPT REAL FUNCTION AKPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'AKPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F82B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- AKPT=FF RETURN END C------------------------------------------------- F83 = WPT REAL FUNCTION WPT(P,T) CHARACTER FUN*6 REAL T0K,PBAR,P,T,FF INTEGER KPA COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'WPT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR TI=T-T0K C--- FUNCTION CALL --- FF = F83B02(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97D05(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D05(3,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- WPT=FF RETURN END *------------------------------------------------- F85D05 = PRPD REAL FUNCTION PRPD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PRPD'/ PI=P CALL S99D02(FNA) PRPD=-1.0E+30 RETURN END *------------------------------------------------- F86D05 = PRPDD REAL FUNCTION PRPDD(P) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PRPDD'/ PI=P CALL S99D02(FNA) PRPDD=-1.0E+30 RETURN END *------------------------------------------------- F87D05 = PRTD REAL FUNCTION PRTD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PRTD'/ TI=T CALL S99D02(FNA) PRTD=-1.0E+30 RETURN END *------------------------------------------------- F88D05 = PRTDD REAL FUNCTION PRTDD(T) CHARACTER FNA*6 COMMON/UNIT/KPA,MESS DATA FNA/'PRTDD'/ TI=T CALL S99D02(FNA) PRTDD=-1.0E+30 RETURN END C *************************************************************** C EXTERNAL FUNCTION C *************************************************************** C ***** SUBROUTINE FOR EROOR MESSAGE **** C*** LEVEL 1 ERROR MESSAGE ***** SUBROUTINE S97D05(FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** NO CONVERGENCE AT '//FUN//' FOR HYDROGEN***' WRITE(6,*) MSG END IF RETURN END C--- LEVEL 2 ERROR CHECK & MESSAGE --- SUBROUTINE S98D05(IPT,P,T,N1,N2,FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,N1*1,N2*1 IF(MESS.NE.0) THEN IF (IPT.EQ.1) THEN C ----FUN(P) TYPE WRITE(6,6010) FUN,P 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR HYDROGEN', & ' WHEN P =',1PE14.7,'*****') C ----FUN(T) TYPE ELSEIF(IPT.EQ.2)THEN WRITE(6,6020) FUN,T 6020 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR HYDROGEN', & ' WHEN T =',1PE14.7,' ****') C--- FUN(P,T)TYPE ELSE WRITE(6,6030) FUN,N1,P,N2,T 6030 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR HYDROGEN', & 'WHEN ',A1,' =',1PE14.7,' AND ',A1,' =',1PE14.7,' ****') ENDIF END IF RETURN END C *** LEVEL 3 ERROR MESSAGE SUBROUTINE S99D02(FNA) COMMON/UNIT/KPA,MESS CHARACTER FNA*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** FUNCTION '//FNA//' UNAVAILABLE FOR HYDROGEN ****' WRITE(6,100) MSG 100 FORMAT(1H ,5X,A) END IF RETURN END C02 + LAPLACE COEFFICIENT AT P REAL FUNCTION F2B02(P) T=F40B02(P) IF (T.EQ.-1E20) GOTO 999 F2B02=G5B02(T) RETURN 999 F2B02=-1E20 RETURN END C03 + LAPLACE COEFFICIENT AT T REAL FUNCTION F3B02(T) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 F3B02=G5B02(T) RETURN 999 F3B02=-1E20 RETURN END C04 + LATENT HEAT OF VAPORIZATION AT P REAL FUNCTION F4B02(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 YP=DBLE(P) YT=G3B02(YP) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) F4B02=REAL((YVG-YVL)*YT*YDPDTS)*1E5 RETURN 999 F4B02=-1E20 RETURN END C05 + LATENT HEAT OF VAPORIZATION AT T REAL FUNCTION F5B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 YT=DBLE(T+273.15) YP=G1B02(YT) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) F5B02=REAL((YVG-YVL)*YT*YDPDTS)*1E5 RETURN 999 F5B02=-1E20 RETURN END C8 + THERMAL CONDUCTIVITY AT P AND T REAL FUNCTION F8B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.0.0) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P) F8B02=REAL(G7B02(YP,YT)) RETURN 999 F8B02=-1E20 RETURN END C13 + VISCOCITY AT P AND T REAL FUNCTION F13B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.0.0) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P) F13B02=REAL(G8B02(YP,YT)) RETURN 999 F13B02=-1E20 RETURN END C18 + ISOBARIC SPECIFIC HEAT AT P AND T REAL FUNCTION F18B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-217.15) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F18B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F18B02=-1E20 ELSE F18B02=REAL(G16B02(YT,YV)) ENDIF RETURN 999 F18B02=-1E20 RETURN END C21 + CRITICAL POINT REAL FUNCTION F21B02(A) CHARACTER*1 A IF (A.EQ.'H') THEN F21B02=8.6902E5 ELSEIF (A.EQ.'P') THEN F21B02=13.152 ELSEIF (A.EQ.'S') THEN F21B02=4.476E4 ELSEIF (A.EQ.'T') THEN F21B02=-239.96 ELSEIF (A.EQ.'V') THEN F21B02=1E0/30.112 ELSE F21B02=-1E20 ENDIF RETURN END C23 + SPECIFIC ENTHALPY OF SATURATED LIQUID AT P REAL FUNCTION F23B02(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 YP=DBLE(P) YT=G3B02(YP) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF23S=REAL(G13B02(YT,YVG)) YF5DH=YF23S-(YVG-YVL)*YT*YDPDTS*1D5 F23B02=YF5DH RETURN 999 F23B02=-1E20 RETURN END C24 + SPECIFIC ENTHALPY OF SATURATED VAPOUR AT P REAL FUNCTION F24B02(P) F24B02=F26B02(P,1E0) RETURN END C25 + SPECIFIC ENTHALPY AT PAND T REAL FUNCTION F25B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F25B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F25B02=-1E20 ELSE F25B02=REAL(G13B02(YT,YV)) ENDIF RETURN END C26 + SPECIFIC ENTHALPY OF MIXTURE AT P REAL FUNCTION F26B02(P,X) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YP=DBLE(P) YT=G3B02(YP) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF23H=G13B02(YT,YVG) YF4DH=YF23H-(YVG-YVL)*YT*YDPDTS*1D5 F26B02=REAL(X*YF23H+(1-X)*YF4DH) RETURN 999 F26B02=-1E20 RETURN END C27 + SPECIFIC ENTHALPY OF SATURATED LIQUID AT T REAL FUNCTION F27B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 YT=DBLE(T+273.15) YP=G1B02(YT) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF27S=REAL(G13B02(YT,YVG)) YF5DH=YF27S-(YVG-YVL)*YT*YDPDTS*1D5 F27B02=YF5DH RETURN 999 F27B02=-1E20 RETURN END C28 + SPECIFIC ENTHALPY OF SATURATED VAPOUR AT T REAL FUNCTION F28B02(T) F28B02=F29B02(T,1E0) RETURN END C29 + SPECIFIC ENTHALPY OF MIXTURE AT T REAL FUNCTION F29B02(T,X) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YT=DBLE(T+273.15) YP=G1B02(YT) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF27H=G13B02(YT,YVG) YF5DH=YF27H-(YVG-YVL)*YT*YDPDTS*1D5 F29B02=REAL(X*YF27H+(1-X)*YF5DH) RETURN 999 F29B02=-1E20 RETURN END C30 + SATURATION PRESSURE AT T REAL FUNCTION F30B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 YT=DBLE(T+273.15) F30B02=REAL(G1B02(YT)) RETURN 999 F30B02=-1E20 RETURN END C31 + SURFACE TENSION AT P REAL FUNCTION F31B02(P) T=F40B02(P) IF (T.EQ.-1E20) GOTO 999 F31B02=G4B02(T) RETURN 999 F31B02=-1E20 RETURN END C32 + SURFACE TENSION AT T REAL FUNCTION F32B02(T) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 F32B02=G4B02(T) RETURN 999 F32B02=-1E20 RETURN END C33 + SPECIFIC ENTROPY OF SATURATED LIQUID AT P REAL FUNCTION F33B02(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 YP=DBLE(P) YT=G3B02(YP) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF33S=REAL(G14B02(YT,YVL)) YF5DS=YF33S-(YVG-YVL)*YDPDTS*1D5 F33B02=YF5DS RETURN 999 F33B02=-1E20 RETURN END C34 + SPECIFIC ENTROPY OF SATURATED VAPOUR AT P REAL FUNCTION F34B02(P) F34B02=F36B02(P,1E0) RETURN END C35 + SPECIFIC ENTROPY AT PAND T REAL FUNCTION F35B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F35B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F35B02=-1E20 ELSE F35B02=REAL(G14B02(YT,YV)) ENDIF RETURN END C36 + SPECIFIC ENTROPY OF MIXTURE AT P REAL FUNCTION F36B02(P,X) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YP=DBLE(P) YT=G3B02(YP) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF33S=G14B02(YT,YVG) YF4DS=YF33S-(YVG-YVL)*YDPDTS*1D5 F36B02=REAL(X*YF33S+(1-X)*YF4DS) RETURN 999 F36B02=-1E20 RETURN END C37 + SPECIFIC ENTROPY OF SATURATED LIQUID AT T REAL FUNCTION F37B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 YT=DBLE(T+273.15) YP=G1B02(YT) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF37S=REAL(G14B02(YT,YVG)) YF5DS=YF37S-(YVG-YVL)*YDPDTS*1D5 F37B02=YF5DS RETURN 999 F37B02=-1E20 RETURN END C38 + SPECIFIC ENTROPY OF SATURATED VAPOUR AT T REAL FUNCTION F38B02(T) F38B02=F39B02(T,1E0) RETURN END C39 + SPECIFIC ENTROPY OF MIXTURE AT T REAL FUNCTION F39B02(T,X) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YT=DBLE(T+273.15) YP=G1B02(YT) YDPDTS=G2B02(YP,YT) CALL S1B02(YT,YVL,YVG) YF37S=G14B02(YT,YVG) YF5DS=YF37S-(YVG-YVL)*YDPDTS*1D5 F39B02=REAL(X*YF37S+(1-X)*YF5DS) RETURN 999 F39B02=-1E20 RETURN END C40 + SATURATION TEMPERATURE AT P REAL FUNCTION F40B02(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 F40B02=REAL(G3B02(DBLE(P)))-273.15 RETURN 999 F40B02=-1E20 RETURN END C41 + TRIPLE POINT REAL FUNCTION F41B02(A) CHARACTER*1 A IF (A.EQ.'P') THEN F41B02=0.07199 ELSEIF (A.EQ.'T') THEN F41B02=-259.19 ELSE F41B02=-1E20 ENDIF RETURN END C42 + SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID AT P REAL FUNCTION F42B02(P) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 900 XX=F23B02(P) IF(XX.LE.-1.E10) GO TO 990 H=XX XX=F49B02(P) IF(XX.LE.-1.E10) GO TO 990 V=XX PP=P*1.E05 F42B02=H-V*PP RETURN 900 XX=-1.E20 990 F42B02=XX RETURN END C43 + SPECIFIC INTERNAL ENERGY OF SATURATED VAPOUR AT P REAL FUNCTION F43B02(P) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 900 XX=F24B02(P) IF(XX.LE.-1.E10) GO TO 990 H=XX XX=F50B02(P) IF(XX.LE.-1.E10) GO TO 990 V=XX PP=P*1.E05 F43B02=H-V*PP RETURN 900 XX=-1.E20 990 F43B02=XX RETURN END C44 + SPECIFIC INTERNAL ENERGY AT PAND T REAL FUNCTION F44B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F44B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F44B02=-1E20 ELSE F44B02=REAL(G13B02(YT,YV))-1E5*YP*YV ENDIF RETURN END C45 + SPECIFIC INTERNAL ENERGY OF MIXTURE AT P REAL FUNCTION F45B02(P,X) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 900 IF (X.LT.0 .OR. X.GT.1) GOTO 900 XX=F42B02(P) IF(XX.LE.-1.E10) GO TO 990 UL=XX XX=F43B02(P) IF(XX.LE.-1.E10) GO TO 990 UV=XX F45B02=UL+X*(UV-UL) RETURN 900 XX=-1.E20 990 F45B02=XX RETURN END C46 + SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID AT T REAL FUNCTION F46B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 900 YT=DBLE(T+273.15) XX=REAL(G1B02(YT)) IF(XX.LE.-1.E10) GO TO 990 PP=XX*1.E05 XX=F27B02(T) IF(XX.LE.-1.E10) GO TO 990 H=XX XX=F53B02(T) IF(XX.LE.-1.E10) GO TO 990 V=XX F46B02=H-V*PP RETURN 900 XX=-1.E20 990 F46B02=XX RETURN END C47 + SPECIFIC INTERNAL ENERGY OF SATURATED VAPOUR AT T REAL FUNCTION F47B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 900 YT=DBLE(T+273.15) XX=REAL(G1B02(YT)) IF(XX.LE.-1.E10) GO TO 990 PP=XX*1.E05 XX=F28B02(T) IF(XX.LE.-1.E10) GO TO 990 H=XX XX=F54B02(T) IF(XX.LE.-1.E10) GO TO 990 V=XX F47B02=H-V*PP RETURN 900 XX=-1.E20 990 F47B02=XX RETURN END C48 + SPECIFIC INTERNAL ENERGY OF MIXTURE AT T REAL FUNCTION F48B02(T,X) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-259.19 .OR. T.GT.-239.96) GOTO 900 IF (X.LT.0 .OR. X.GT.1) GOTO 900 XX=F46B02(T) IF(XX.LE.-1.E10) GO TO 990 UL=XX XX=F47B02(T) IF(XX.LE.-1.E10) GO TO 990 UV=XX F48B02=UL+X*(UV-UL) RETURN 900 XX=-1.E20 990 F48B02=XX RETURN END C49 + SPECIFIC VOLUME OF SATURATED LIQUID AT P REAL FUNCTION F49B02(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 YP=DBLE(P) YT=G3B02(YP) CALL S1B02(YT,YVL,YVG) F49B02=REAL(YVL) RETURN 999 F49B02=-1E20 RETURN END C50 + SPECIFIC VOLUME OF SATURATED GAS AT P REAL FUNCTION F50B02(P) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 YP=DBLE(P) YT=G3B02(YP) CALL S1B02(YT,YVL,YVG) F50B02=REAL(YVG) RETURN 999 F50B02=-1E20 RETURN END C51 + SPECIFIC VOLUME AT P AND T REAL FUNCTION F51B02(P,T) IMPLICIT DOUBLE PRECISION (G,V,Y) YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F51B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F51B02=-1E20 ELSE F51B02=REAL(YV) ENDIF RETURN END C52 + SPECIFIC VOLUME OF MIXTURE AT P REAL FUNCTION F52B02(P,X) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YP=DBLE(P) YT=G3B02(YP) CALL S1B02(YT,YVL,YVG) F52B02=REAL(YVL+X*(YVG-YVL)) RETURN 999 F52B02=-1E20 RETURN END C53 + SPECIFIC VOLUME OF SATURATED LIQUID AT T REAL FUNCTION F53B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 YT=DBLE(T+273.15) CALL S1B02(YT,YVL,YVG) F53B02=REAL(YVL) RETURN 999 F53B02=-1E20 RETURN END C54 + SPECIFIC VOLUME OF SATURATED GAS AT T REAL FUNCTION F54B02(T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 YT=DBLE(T+273.15) CALL S1B02(YT,YVL,YVG) F54B02=REAL(YVG) RETURN 999 F54B02=-1E20 RETURN END C55 + SPECIFIC VOLUME OF MIXTURE AT T REAL FUNCTION F55B02(T,X) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 IF (X.LT.0 .OR. X.GT.1) GOTO 999 YT=DBLE(T+273.15) CALL S1B02(YT,YVL,YVG) F55B02=REAL(YVL+X*(YVG-YVL)) RETURN 999 F55B02=-1E20 RETURN END C56 + DRYNESS FRACTION <-> AT P,H REAL FUNCTION F56B02(P,H) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 HD=F23B02(P) HDD=F24B02(P) IF (H.LT.HD .OR. H.GT.HDD) GOTO 999 F56B02=(H-HD)/(HDD-HD) RETURN 999 F56B02=-1E20 RETURN END C57 + DRYNESS FRACTION <-> AT P,S REAL FUNCTION F57B02(P,S) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 SD=F33B02(P) SDD=F34B02(P) IF (S.LT.SD .OR. S.GT.SDD) GOTO 999 F57B02=(S-SD)/(SDD-SD) RETURN 999 F57B02=-1E20 RETURN END C58 + DRYNESS FRACTION <-> AT P,U REAL FUNCTION F58B02(P,U) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 UD=F42B02(P) UDD=F43B02(P) IF (U.LT.UD .OR. U.GT.UDD) GOTO 999 F58B02=(U-UD)/(UDD-UD) RETURN 999 F58B02=-1E20 RETURN END C59 + DRYNESS FRACTION <-> AT P,V REAL FUNCTION F59B02(P,V) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT..07199 .OR. P.GT.13.152) GOTO 999 YP=DBLE(P) YT=G3B02(YP) CALL S1B02(YT,YVL,YVG) YVV=DBLE(V) IF (YVV.LT.YVL .OR. YVV.GT.YVG) GOTO 999 F59B02=REAL((YVV-YVL)/(YVG-YVL)) RETURN 999 F59B02=-1E20 RETURN END C60 + DRYNESS FRACTION <-> AT T,H REAL FUNCTION F60B02(T,H) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 HD=F27B02(T) HDD=F28B02(T) IF (H.LT.HD .OR. H.GT.HDD) GOTO 999 F60B02=(H-HD)/(HDD-HD) RETURN 999 F60B02=-1E20 RETURN END C61 + DRYNESS FRACTION <-> AT T,S REAL FUNCTION F61B02(T,S) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 SD=F37B02(T) SDD=F38B02(T) IF (S.LT.SD .OR. S.GT.SDD) GOTO 999 F61B02=(S-SD)/(SDD-SD) RETURN 999 F61B02=-1E20 RETURN END C62 + DRYNESS FRACTION <-> AT T,U REAL FUNCTION F62B02(T,U) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 UD=F46B02(T) UDD=F47B02(T) IF (U.LT.UD .OR. U.GT.UDD) GOTO 999 F62B02=(U-UD)/(UDD-UD) RETURN 999 F62B02=-1E20 RETURN END C63 + DRYNESS FRACTION <-> AT T,V REAL FUNCTION F63B02(T,V) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LT.-259.19 .OR. T.GT.-239.96) GOTO 999 YT=DBLE(T+273.15) CALL S1B02(YT,YVL,YVG) YVV=DBLE(V) IF (YVV.LT.YVL .OR. YVV.GT.YVG) GOTO 999 F63B02=REAL((YVV-YVL)/(YVG-YVL)) RETURN 999 F63B02=-1E20 RETURN END C64 + TEMPERATURE AT P AND H REAL FUNCTION F64B02(P,H) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P) YH=DBLE(H) CALL S2B02(YP,YH,YT,YV) TK=REAL(YT) IF (TK.GE.0.0) THEN F64B02=TK-273.15 ELSE F64B02=TK ENDIF RETURN END C65 + TEMPERATURE AT P AND S REAL FUNCTION F65B02(P,S) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P) YS=DBLE(S) CALL S3B02(YP,YS,YT,YV) TK=REAL(YT) IF (TK.GE.0.0) THEN F65B02=TK-273.15 ELSE F65B02=TK ENDIF RETURN END C70 + TEMPERATURE AT P AND V REAL FUNCTION F70B02(P,V) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P) YV=DBLE(V) TK=G12B02(YP,YV) IF (TK.GE.0.0) THEN F70B02=TK-273.15 ELSE F70B02=TK ENDIF RETURN END C71 + ENTHALPY AT P AND S REAL FUNCTION F71B02(P,S) IMPLICIT DOUBLE PRECISION (G,Y) X=F57B02(P,S) IF (X.LT.0.0 .OR. X.GT.1.0) GOTO 10 F71B02=F26B02(P,X) RETURN 10 YP=DBLE(P) YS=DBLE(S) CALL S3B02(YP,YS,YT,YV) IF (YT.LT.-1E9) GOTO 999 T=REAL(YT)-273.15 F71B02=F25B02(P,T) RETURN 999 F71B02=REAL(YT) RETURN END C77 + ISOCHORIC SPECIFIC HEAT AT P AND T REAL FUNCTION F77B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF(T.LT.-217.15) GOTO 999 YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F77B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F77B02=-1E20 ELSE F77B02=REAL(G15B02(YT,YV)) ENDIF RETURN 999 F77B02=-1E20 RETURN END C81 + PRANDTLE NUMBER < - > AT P AND T REAL FUNCTION F81B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LE.0.0) GOTO 999 YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F81B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F81B02=-1E20 ELSE F81B02=G8B02(YP,YT)*G16B02(YT,YV)/G7B02(YP,YT) ENDIF RETURN 999 F81B02=-1E20 RETURN END C82 + ADIABATIC EXPONENT < - > AT P AND T REAL FUNCTION F82B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LE.0.0) GOTO 999 YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) IF (YV.EQ.-1E10) THEN F82B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F82B02=-1E20 ELSE F82B02=-YV/YP*G18B02(YT,YV)*G16B02(YT,YV)/G15B02(YT,YV)*1D-5 ENDIF RETURN 999 F82B02=-1E20 RETURN END C83 + SOUND VELOCITY AT P AND T REAL FUNCTION F83B02(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (T.LE.0.0) GOTO 999 YP=DBLE(P) YT=DBLE(T+273.15) YV=G10B02(YP,YT) YKK=-YV/YP*G18B02(YT,YV)*G16B02(YT,YV)/G15B02(YT,YV)*1D-5 IF (YV.EQ.-1E10) THEN F83B02=-1E10 ELSEIF (YV.EQ.-1E20) THEN F83B02=-1E20 ELSE F83B02=SQRT(YP*YV*1D5*YKK) ENDIF RETURN 999 F83B02=-1E20 RETURN END CG01 *** PS(T) DOUBLE PRECISION FUNCTION G1B02(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A0/4.66687D0/,A1/-4.49569D1/, & A2/0.020537D0/ P0=(A0+A1/T+A2*T)*DLOG(10.D0) G1B02=DEXP(P0)/750.06 RETURN END CG02 *** DPS/DT(T) ---- DOUBLE PRECISION FUNCTION G2B02(P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A1/-4.49569D1/, & A2/0.020537D0/ DP0=(-A1/T/T+A2)*DLOG(10.D0) G2B02=P*DP0 RETURN END CG03 *** TS(P) ---- DOUBLE PRECISION FUNCTION G3B02(P) IMPLICIT DOUBLE PRECISION (A-H,O-Z) T0=13.96D0-(0.07199-P)*1.470D0 10 P0=G1B02(T0) DPDT=G2B02(P0,T0) T1=T0+(P-P0)/DPDT IF (DABS((T1-T0)/T1) .GE. 1D-6) THEN T0=T1 GOTO 10 ELSE G3B02=T1 ENDIF RETURN END CG04 *** SURFACE TENSION AT T REAL FUNCTION G4B02(T) IF(T.GT.-240.2) GOTO 999 SIG1=2.41E-3 RDT=(-240.2-T)/(-240.2+256.0) SIG=SIG1*RDT**1.1012 IF (SIG.LT.1E-6) SIG=0 G4B02=SIG RETURN 999 SIG=0 G4B02=SIG RETURN END CG05 *** LAPLACE COEFFICIENT AT T REAL FUNCTION G5B02(T) IMPLICIT DOUBLE PRECISION (Y) YT=DBLE(T+273.15) CALL S1B02(YT,YVL,YVG) RV=REAL(YVL*YVG/(YVG-YVL)) SIG=G4B02(T) G5B02=SQRT(SIG*RV/9.80665) RETURN END CG07 *** ALMPT(P,T)-- DOUBLE PRECISION FUNCTION G7B02(P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) P=P/100.0D0 TT=T/100.0D0 ALM=-0.2123577D2+0.4534641D2*P-0.5920373D1*P**2 &-0.1641437D1*P**3+0.3268894D0*P**4 &+TT*(0.3009291D2-0.2494924D2*P+0.9220505D1*P**2 &+0.1001922D1*P**3-0.2972730D0*P**4) &+TT**2*(0.6180956D2+0.9640122D1*P-0.4324041D1*P**2 &+0.1481649D-1*P**3+0.7044168D-1*P**4) &+TT**3*(-0.3487603D1-0.1296965D1*P+0.6347331D0*P**2 &-0.3226335D-1*P**3-0.6106939D-2*P**4) &+TT**4*(0.1511541D0+0.5528987D-1*P-0.2865920D-1*P**2 &+0.2237938D-2*P**3+0.1670707D-3*P**4) ALM=ALM/TT G7B02=ALM/1.0D3 RETURN END CG08 *** AMUPT(P,T)-------- DOUBLE PRECISION FUNCTION G8B02(P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) P=P/100.0D0 TT=T/100.0D0 AMU=(-0.2646440D3+0.5559073D2*P+0.2163660D2*P**2 &-0.2216953D1*P**3+0.6948894D-1*P**4)/TT &+0.4495399D3-0.1291285D2*P+0.3444739D0*P**2 &-0.2832608D0*P**3+0.2625730D-1*P**4 &+(0.1863207D3+0.2150074D1*P-0.1017287D1*P**2 &+0.2269941D0*P**3-0.1338267D-1*P**4)*TT &+(-0.2761352D1-0.1147974D0*P+0.7752600D-1*P**2 &-0.1652767D-1*P**3+0.9267481D-3*P**4)*TT**2 G8B02=AMU/1.0D8 RETURN END CG09 *** P(T,V) - ANALYSIS - IUPAC P DOUBLE PRECISION FUNCTION G9B02(T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B0(10),C0(10),C1(10),C2(10) DATA B0(1)/0.0055478D0/,B0(2)/-0.036877D0/,B0(3)/-0.22004D0/ DATA C0(1)/0.004788D0/,C0(2)/-0.04053D0/ DATA C1(1)/0.45020D0/,C1(2)/0.014135D0/,C1(3)/-4.3851D-04/, &C1(4)/5.0490D-06/,C1(5)/-2.7076D-08/ DATA C2(1)/-5.3762D0/,C2(2)/-0.030609D0/,C2(3)/1.3752D-03/, &C2(4)/-3.2698D-05/,C2(5)/1.6450D-07/ GASC=4.12462D3 WW=1D0/(0.08988D0*V) IF (T.LT.56.0) GOTO 10 BK=B0(1)*T**(-0.25)+B0(2)*T**(-0.75)+B0(3)*T**(-1.25) CK=C0(1)*T**(-1.5)+C0(2)*T**(-2) ZZ=DEXP(BK*WW+CK*WW**2) G9B02=ZZ*GASC*T/V*1D-5 RETURN 10 CONTINUE DK=C1(1)+C1(2)*T+C1(3)*T**2+C1(4)*T**3+C1(5)*T**4 EK=(C2(1)+C2(2)*T+C2(3)*T**2+C2(4)*T**3+C2(5)*T**4)*1.0D-7 ZZ=1.0-DK*WW/T**1.5-EK*WW**2/T**1.5 G9B02=ZZ*GASC*T/V*1D-5 RETURN END CG10 *** V(P,T) - FROM IUPAC ANALYSIS P(T,V) BY NEWTON-METHOD DOUBLE PRECISION FUNCTION G10B02(P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (P.LT.0.071990D0 .OR. P.GT.5D2) GOTO 999 TMIN=13.96D0 TMAX=673.15D0 IF (P.GE.13.152.AND.P.LE.500) THEN TMIN=29.23D0+0.30101*P ELSEIF(P.LT.13.152) THEN TMIN=13.96D0-1.470D0*(0.07199-P) ENDIF VMIN=0.02225D0 VMAX=22.34D0 IF (T.LT.TMIN.OR.T.GT.TMAX) GOTO 999 IF (P.LE.0.07199D0) GOTO 999 IF (P.LE.13.152) THEN TS=G3B02(P) CALL S1B02(TS,VL,VG) IF (T.LT.TS) GOTO 999 VMIN=VG VMAX=22.34D0 ELSEIF (P.LE.0.1853) THEN VMIN=VG VMAX=20.623D0/P ENDIF V1=G11B02(VMAX,VMIN,P,T) IF (V1.LT.-1.E+8) GO TO 888 ILOOP=0 10 ILOOP=ILOOP+1 IF (V1.LE.0.0) GOTO 999 IF (ILOOP.GT.10000) GOTO 888 P1=G9B02(T,V1) DP1DV=G18B02(T,V1) V2=1D5*(P-P1)/DP1DV+V1 IF (DABS((V2-V1)/V2).LT.1D-4) THEN G10B02=V2 RETURN ELSE V1=V2 GOTO 10 ENDIF 888 G10B02=-1E10 RETURN 999 G10B02=-1E20 RETURN END CG11 *** DOUBLE PRECISION FUNCTION G11B02(VMAX,VMIN,P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 VA=VMAX VB=VMIN 10 PA=G9B02(T,VA) PB=G9B02(T,VB) IF (PA.LT.1.D-60.OR.PA.GT.1.D+60) GO TO 888 IF (PB.LT.1.D-60.OR.PB.GT.1.D+60) GO TO 888 DPA=P-PA DPB=P-PB DPAB=PA-PB VC=VB+(VA-VB)*.5 PC=G9B02(T,VC) IF (PC.LT.1.D-60.OR.PC.GT.1.D+60) GO TO 888 DPC=P-PC IF (DPA*DPC.LE.0.0 .AND. DPB*DPC.GT.0.0) THEN VA=VA VB=VC ELSEIF (DPA*DPC.GT.0.0 .AND. DPB*DPC.LE.0.0) THEN VA=VC VB=VB ELSE VA=1.1*VA VB=0.9*VB ENDIF ILOOP=ILOOP+1 IF (ILOOP.LT.10000) GOTO 20 888 G11B02=-1E10 RETURN 20 IF (DABS(VA-VB)/VB.GT.1E-5) GOTO 10 G11B02=VC RETURN END CG12 *** T(P0,V0) FROM P(T,V0)-P0=0 DOUBLE PRECISION FUNCTION G12B02(P,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 IF (P.LT.0.071990D0 .OR. P.GT.5D2) GOTO 999 TMIN=13.96D0 TMAX=673.15D0 IF (P.GE.13.152.AND.P.LE.500) THEN TMIN=29.23D0+0.30101*P ELSEIF (P.LE.13.152) THEN TMIN=13.96D0-1.470D0*(0.07199-P) ENDIF VMAX=G10B02(P,TMAX) VMIN=G10B02(P,TMIN) IF (V.LT.VMIN .OR. V.GT.VMAX) GOTO 999 IF (VMAX.LT.-1.E+8.OR.VMAX.LT.-1.E+8) GO TO 888 IF ( P.LT..07199 .OR. P.GT.13.152) GOTO 5 YT=G3B02(P) CALL S1B02(YT,VL,VG) IF (V.LT.VL) THEN TA=YT TB=TMIN ELSEIF (V.LE.VG) THEN G12B02=YT RETURN ELSE TA=TMAX TB=YT ENDIF GOTO 10 5 TA=TMAX TB=TMIN 10 VA=G10B02(P,TA) VB=G10B02(P,TB) IF (VA.LT.-1.E+8.OR.VB.LT.-1.E+8) GO TO 888 DVA=V-VA DVB=V-VB DVAB=VA-VB TC=TB+(TA-TB)*.5 VC=G10B02(P,TC) IF (VC.LT.-1.E+8) GO TO 888 DVC=V-VC IF (DVA*DVC.LE.0.0 .AND. DVB*DVC.GT.0.0) THEN TA=TA TB=TC ELSEIF (DVA*DVC.GT.0.0 .AND. DVB*DVC.LE.0.0) THEN TA=TC TB=TB ELSE GOTO 777 ENDIF 777 ILOOP=ILOOP+1 IF (ILOOP.GT.10000) GOTO 888 IF (DABS(TA-TB)/TB.GT.1E-6) GOTO 10 G12B02=TC RETURN 888 G12B02=-1E10 RETURN 999 G12B02=-1E20 RETURN END CG13 *** H(T,V)-ANALYSIS--IUPAC H(T,V)/(R*T) <-> DOUBLE PRECISION FUNCTION G13B02(T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B0(10),C0(10),C1(10),C2(10),C3(10),C4(10) DATA B0(1)/0.0055478D0/,B0(2)/-0.036877D0/,B0(3)/-0.22004D0/ DATA C0(1)/0.004788D0/,C0(2)/-0.04053D0/ DATA C1(1)/0.45020D0/,C1(2)/0.014135D0/,C1(3)/-4.3851D-04/, &C1(4)/5.0490D-06/,C1(5)/-2.7076D-08/ DATA C2(1)/-5.3762D0/,C2(2)/-0.030609D0/,C2(3)/1.3752D-03/, &C2(4)/-3.2698D-05/,C2(5)/1.6450D-07/ DATA C3(1)/0.079246D0/,C3(2)/-1.230903D-03/,C3(3)/-1.718230D-04/, &C3(4)/4.7885929D-06/,C3(5)/-3.8425508D-08/ DATA C4(1)/35.9301D0/,C4(2)/-17.3590D0/,C4(3)/1.10007D0/, &C4(4)/-0.03445D0/,C4(5)/2.91959D-04/ GASC=4.12462D3 WW=1D0/(0.08988D0*V) IF (T.LT.56.0) GOTO 10 BK=B0(1)*T**(-0.25)+B0(2)*T**(-0.75)+B0(3)*T**(-1.25) CK=C0(1)*T**(-1.5)+C0(2)*T**(-2) BKDT=-0.25D0*B0(1)*T**(-1.25)-0.75D0*B0(2)*T**(-1.75) &-1.25D0*B0(3)*T**(-2.25) CKDT=-1.5D0*C0(1)*T**(-2.5)-2.0D0*C0(2)*T**(-3) ZZ=BKDT*WW+(BKDT*BK+CKDT)*WW**2/2.0D0 &+(BK**2*BKDT/2.0D0+CK*BKDT+BK*CKDT)*WW**3/3.0D0 &+(BK**3*BKDT/6.0D0+CK*CKDT+BK*CK*BKDT+BK**2*CKDT/2.0D0) &*WW**4/4.0D0 ZZ=-T*ZZ GOTO 20 10 CONTINUE DK=C1(1)+C1(2)*T+C1(3)*T**2+C1(4)*T**3+C1(5)*T**4 EK=(C2(1)+C2(2)*T+C2(3)*T**2+C2(4)*T**3+C2(5)*T**4)*1.0D-7 DKDT=C3(1)+C3(2)*T+C3(3)*T**2+C3(4)*T**3+C3(5)*T**4 EKDT=(C4(1)+C4(2)*T+C4(3)*T**2+C4(4)*T**3+C4(5)*T**4)*1.0D-8 ZZ1=-1.5D0*(DK*WW+EK*WW**2/2.0D0)/T**1.5+WW*DKDT/T**0.5 ZZ=(ZZ1+EKDT*WW**2/T**0.5/2.0D0) 20 CONTINUE GASC=4.12462D3 RC=GASC CALL S4B02(T,AHT0,ST0,CP0) P=G9B02(T,V) G13B02=AHT0-RC*T+P*V*1D5+RC*T*ZZ RETURN END CG14 *** S(T,V) - ANALYSIS - IUPAC S(T,V)/R <-> DOUBLE PRECISION FUNCTION G14B02(T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B0(10),C0(10),C1(10),C2(10),C3(10),C4(10) DATA B0(1)/0.0055478D0/,B0(2)/-0.036877D0/,B0(3)/-0.22004D0/ DATA C0(1)/0.004788D0/,C0(2)/-0.04053D0/ DATA C1(1)/0.45020D0/,C1(2)/0.014135D0/,C1(3)/-4.3851D-04/, &C1(4)/5.0490D-06/,C1(5)/-2.7076D-08/ DATA C2(1)/-5.3762D0/,C2(2)/-0.030609D0/,C2(3)/1.3752D-03/, &C2(4)/-3.2698D-05/,C2(5)/1.6450D-07/ DATA C3(1)/0.079246D0/,C3(2)/-1.230903D-03/,C3(3)/-1.718230D-04/, &C3(4)/4.7885929D-06/,C3(5)/-3.8425508D-08/ DATA C4(1)/35.9301D0/,C4(2)/-17.3590D0/,C4(3)/1.10007D0/, &C4(4)/-0.03445D0/,C4(5)/2.91959D-04/ GASC=4.12462D3 WW=1D0/(0.08988D0*V) IF (T.LT.56.0) GOTO 10 BK=B0(1)*T**(-0.25)+B0(2)*T**(-0.75)+B0(3)*T**(-1.25) CK=C0(1)*T**(-1.5)+C0(2)*T**(-2) BKDT=-0.25D0*B0(1)*T**(-1.25)-0.75D0*B0(2)*T**(-1.75) &-1.25D0*B0(3)*T**(-2.25) CKDT=-1.5D0*C0(1)*T**(-2.5)-2.0D0*C0(2)*T**(-3) ZZ=BK*WW+(BK**2/2.0D0+CK)*WW**2/2.0D0 &+(BK**3/6.0D0+BK*CK)*WW**3/3.0D0 &+(BK**4/24.0D0+CK**2/2.0D0+BK**2*CK/2.0D0) &*WW**4/4.0D0 &+T*(BKDT*WW+(BK*BKDT+CKDT)*WW**2/2.0D0 &+(BK**2*BKDT/2.0D0+CK*BKDT+BK*CKDT)*WW**3/3.0D0 &+(BK**3*BKDT/6.0D0+CK*CKDT+BK*CK*BKDT+BK**2*CKDT/2.0D0) &*WW**4/4.0D0) GOTO 20 10 CONTINUE DK=C1(1)+C1(2)*T+C1(3)*T**2+C1(4)*T**3+C1(5)*T**4 EK=(C2(1)+C2(2)*T+C2(3)*T**2+C2(4)*T**3+C2(5)*T**4)*1.0D-7 DKDT=C3(1)+C3(2)*T+C3(3)*T**2+C3(4)*T**3+C3(5)*T**4 EKDT=(C4(1)+C4(2)*T+C4(3)*T**2+C4(4)*T**3+C4(5)*T**4)*1.0D-8 ZZ1=-0.5D0*(DK*WW+EK*WW**2/2.0D0)/T**1.5+WW*DKDT/T**0.5 ZZ=(ZZ1+EKDT*WW**2/T**0.5/2.0D0) 20 CONTINUE GASC=4.12462D3 RC=GASC PP0=1.01325D5 CALL S4B02(T,AHT0,ST0,CP0) G14B02=ST0-RC*DLOG(RC*T/PP0/V)+RC*ZZ RETURN END CG15 *** CV(T,V) - IUPAC - ANALYSIS CV/R <-> DOUBLE PRECISION FUNCTION G15B02(T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B0(10),C0(10) DATA B0(1)/0.0055478D0/,B0(2)/-0.036877D0/,B0(3)/-0.22004D0/ DATA C0(1)/0.004788D0/,C0(2)/-0.04053D0/ GASC=4.12462D3 WW=1D0/(0.08988D0*V) BK=B0(1)*T**(-0.25)+B0(2)*T**(-0.75)+B0(3)*T**(-1.25) CK=C0(1)*T**(-1.5)+C0(2)*T**(-2) BKDT=-0.25D0*B0(1)*T**(-1.25)-0.75D0*B0(2)*T**(-1.75) &-1.25D0*B0(3)*T**(-2.25) CKDT=-1.5D0*C0(1)*T**(-2.5)-2.0D0*C0(2)*T**(-3) BKDDT=1.25D0*0.25D0*B0(1)*T**(-2.25)+1.75D0*0.75D0*B0(2)*T**(-2.75 &)+2.25D0*1.25D0*B0(3)*T**(-3.25) CKDDT=2.5D0*1.5D0*C0(1)*T**(-3.5)+3.0D0*2.0D0*C0(2)*T**(-4) ZZ=2.0*(BKDT*WW+(BK*BKDT+CKDT)*WW**2/2.0D0 &+(BK**2*BKDT/2.0D0+BKDT*CK+BK*CKDT)*WW**3/3.0D0 &+(BK**3*BKDT/6.0D0+CK*CKDT+BK*CK*BKDT+BK**2*CKDT/2.0D0) &*WW**4/4.0D0) &+T*(BKDDT*WW+(BKDT**2+BK*BKDDT+CKDDT)*WW**2/2.0D0 &+(BKDT**2*BK+BK**2*BKDDT/2.0D0+CK*BKDDT+BK*CKDDT &+2.0D0*BKDT*CKDT)*WW**3/3.0D0 &+(BK**2*BKDT**2/2.0D0+BK**3*BKDDT/6.0D0+CKDT**2 &+CK*CKDDT+BKDT**2*CK+2.0*BK*BKDT*CKDT &+CK*BK*BKDDT+BK**2*CKDDT/2.0D0) &*WW**4/4.0D0) CALL S4B02(T,AHT0,ST0,CP0) CP0=CP0-GASC G15B02=-T*ZZ*GASC+CP0 RETURN END CG16 *** CP(T,V) - IUPAC - ANALYSIS CP/R <-> DOUBLE PRECISION FUNCTION G16B02(T,V) IMPLICIT DOUBLE PRECISION (G,T,V) G16B02=G15B02(T,V)-(G17B02(T,V))**2/G18B02(T,V)*T RETURN END CG17 *** DP/DT(T,V0) - IUPAC -ANALYSIS DOUBLE PRECISION FUNCTION G17B02(T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B0(10),C0(10),C1(10),C2(10),C3(10),C4(10) DATA B0(1)/0.0055478D0/,B0(2)/-0.036877D0/,B0(3)/-0.22004D0/ DATA C0(1)/0.004788D0/,C0(2)/-0.04053D0/ DATA C1(1)/0.45020D0/,C1(2)/0.014135D0/,C1(3)/-4.3851D-04/, &C1(4)/5.0490D-06/,C1(5)/-2.7076D-08/ DATA C2(1)/-5.3762D0/,C2(2)/-0.030609D0/,C2(3)/1.3752D-03/, &C2(4)/-3.2698D-05/,C2(5)/1.6450D-07/ DATA C3(1)/0.079246D0/,C3(2)/-1.230903D-03/,C3(3)/-1.718230D-04/, &C3(4)/4.7885929D-06/,C3(5)/-3.8425508D-08/ DATA C4(1)/35.9301D0/,C4(2)/-17.3590D0/,C4(3)/1.10007D0/, &C4(4)/-0.03445D0/,C4(5)/2.91959D-04/ GASC=4.12462D3 WW=1D0/(0.08988D0*V) IF (T.LT.56.0) GOTO 10 BK=B0(1)*T**(-0.25)+B0(2)*T**(-0.75)+B0(3)*T**(-1.25) CK=C0(1)*T**(-1.5)+C0(2)*T**(-2) BKDT=-0.25D0*B0(1)*T**(-1.25)-0.75D0*B0(2)*T**(-1.75) &-1.25D0*B0(3)*T**(-2.25) CKDT=-1.5D0*C0(1)*T**(-2.5)-2.0D0*C0(2)*T**(-3) ZZ=DEXP(BK*WW+CK*WW**2) ZAZ=ZZ*(BKDT*WW+CKDT*WW**2) G17B02=ZAZ*GASC*T/V+GASC/V*ZZ RETURN 10 CONTINUE DK=C1(1)+C1(2)*T+C1(3)*T**2+C1(4)*T**3+C1(5)*T**4 EK=(C2(1)+C2(2)*T+C2(3)*T**2+C2(4)*T**3+C2(5)*T**4)*1.0D-7 DKDT=C3(1)+C3(2)*T+C3(3)*T**2+C3(4)*T**3+C3(5)*T**4 EKDT=(C4(1)+C4(2)*T+C4(3)*T**2+C4(4)*T**3+C4(5)*T**4)*1.0D-8 ZZ=1.0-DK*WW/T**1.5-EK*WW**2/T**1.5 ZAZ=1.5*(1-ZZ)/T-DKDT*WW/T**1.5-EKDT*WW**2/T**1.5 G17B02=GASC/V*ZAZ*T+GASC/V*ZZ RETURN END CG18 *** DP/DV(T0,V) - IUPAC - ANALYSIS DOUBLE PRECISION FUNCTION G18B02(T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B0(10),C0(10),C1(10),C2(10) DATA B0(1)/0.0055478D0/,B0(2)/-0.036877D0/,B0(3)/-0.22004D0/ DATA C0(1)/0.004788D0/,C0(2)/-0.04053D0/ DATA C1(1)/0.45020D0/,C1(2)/0.014135D0/,C1(3)/-4.3851D-04/, &C1(4)/5.0490D-06/,C1(5)/-2.7076D-08/ DATA C2(1)/-5.3762D0/,C2(2)/-0.030609D0/,C2(3)/1.3752D-03/, &C2(4)/-3.2698D-05/,C2(5)/1.6450D-07/ GASC=4.12462D3 WW=1D0/(0.08988D0*V) IF (T.LT.56.0) GOTO 10 BK=B0(1)*T**(-0.25)+B0(2)*T**(-0.75)+B0(3)*T**(-1.25) CK=C0(1)*T**(-1.5)+C0(2)*T**(-2) ZAZ=DEXP(BK*WW+CK*WW**2) ZBZ=WW*(BK+2.0D0*CK*WW)*ZAZ GOTO 20 10 CONTINUE DK=C1(1)+C1(2)*T+C1(3)*T**2+C1(4)*T**3+C1(5)*T**4 EK=(C2(1)+C2(2)*T+C2(3)*T**2+C2(4)*T**3+C2(5)*T**4)*1.0D-7 ZAZ=1.0-DK*WW/T**1.5-EK*WW**2/T**1.5 ZBZ=-WW*(DK+2.0D0*EK*WW)/T**1.5 20 ZZ=ZAZ+ZBZ G18B02=(GASC*T*ZZ)*(-1D0/V/V) RETURN END CS1 *****VD(T),VDD(T) SUBROUTINE S1B02(T,VL,VG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION F1(10),F2(10),F3(10) DATA F1(1)/26942.855929D0/,F1(2)/-14275.4152456D0/, &F1(3)/2607.7436166D0/,F1(4)/-234.2462693335D0/, &F1(5)/11.1392084976D0/,F1(6)/-0.2364502616D0/, &F1(7)/-1.6163036318D-3/,F1(8)/2.0061667958D-4/, &F1(9)/-4.0663418042D-6/,F1(10)/2.8488777947D-8/ DATA F2(1)/-74.257774D0/,F2(2)/21.377672D0/, &F2(3)/-2.41806635D0/,F2(4)/0.133028734D0/, &F2(5)/-3.5775398D-3/,F2(6)/4.231899D-5/ DATA F3(1)/472281.16808D0/,F3(2)/-65694.58436D0/, &F3(3)/3420.9666004D0/,F3(4)/-79.0477690437D0/, &F3(5)/0.6840648353D0/ IF (T.LT.20.0) THEN VL=24.747-0.08005*T+0.012716*T**2 VL=VL*1.0D-3/2.016 ELSE VL=F1(1)+F1(2)*T+F1(3)*T**2+F1(4)*T**3+F1(5)*T**4 &+F1(6)*T**5+F1(7)*T**6+F1(8)*T**7+F1(9)*T**8+F1(10)*T**9 VL=VL*1.0D-3/2.016 ENDIF IF (T.LT.26.0) THEN VG=F2(1)+F2(2)*T+F2(3)*T**2+F2(4)*T**3+F2(5)*T**4+F2(6)*T**5 ELSE VG=F3(1)+F3(2)*T+F3(3)*T**2+F3(4)*T**3+F3(5)*T**4 ENDIF VG=1.0D0/(0.089888D0*VG) RETURN END CS2 *** T(P0,H0) V(P0,H0) FROM P(T,V)-P0=0 AND H(T,V)-H0=0 SUBROUTINE S2B02(P,H,T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 IF (P.LT.0.071990D0 .OR. P.GT.5D2) GOTO 999 TMIN=13.96D0 TMAX=673.15D0 IF (P.GE.13.152.AND.P.LE.500) THEN TMIN=29.23D0+0.30101*P ELSEIF (P.LE.13.152) THEN TMIN=13.96D0-1.470D0*(0.07199-P) ENDIF IF ( P.LT..07199 .OR. P.GT.13.152) GOTO 5 VMAX=G10B02(P,TMAX) VMIN=G10B02(P,TMIN) HMAX=G13B02(TMAX,VMAX) HMIN=G13B02(TMIN,VMIN) IF (H.LT.HMIN .OR. H.GT.HMAX) GOTO 999 YT=G3B02(P) CALL S1B02(YT,VL,VG) HD=G13B02(YT,VL) HDD=HD+1D5*(VG-VL)*G2B02(P,YT) IF (H.LT.HD) THEN TA=YT TB=TMIN ELSEIF (H.LE.HDD) THEN T=YT V=VL+(VG-VL)*(H-HD)/(HDD-HD) RETURN ELSE TA=TMAX TB=YT ENDIF GOTO 10 5 TA=TMAX TB=TMIN 10 VA=G10B02(P,TA) VB=G10B02(P,TB) IF (VA.LT.-1.E+8.OR.VB.LT.-1.E+8) GO TO 888 HA=G13B02(TA,VA) HB=G13B02(TB,VB) DHA=H-HA DHB=H-HB DHAB=HA-HB TC=TB+(TA-TB)*.5 VC=G10B02(P,TC) IF (VC.LT.-1.E+8) GO TO 888 HC=G13B02(TC,VC) DHC=H-HC IF (DHA*DHC.LE.0.0 .AND. DHB*DHC.GT.0.0) THEN TA=TA TB=TC ELSEIF (DHA*DHC.GT.0.0 .AND. DHB*DHC.LE.0.0) THEN TA=TC TB=TB ELSE GOTO 777 ENDIF 777 ILOOP=ILOOP+1 IF (ILOOP.GT.10000) GOTO 888 IF (DABS(TA-TB)/TB.GT.1E-6) GOTO 10 T=TC V=G10B02(P,T) RETURN 888 T=-1E10 V=-1E10 RETURN 999 T=-1E20 V=-1E20 RETURN END CS3 *** T(P0,S0) V(P0,S0) FROM P(T,V)-P0=0 AND S(T,V)-S0=0 SUBROUTINE S3B02(P,S,T,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 IF (P.LT.0.071990D0 .OR. P.GT.5D2) GOTO 999 TMIN=13.96D0 TMAX=673.15D0 IF (P.GE.13.152.AND.P.LE.500) THEN TMIN=29.23D0+0.30101*P ELSEIF (P.LE.13.152) THEN TMIN=13.96D0-1.470D0*(0.07199-P) ENDIF VMAX=G10B02(P,TMAX) VMIN=G10B02(P,TMIN) IF (VMAX.LT.-1.E+8.OR.VMIN.LT.-1.E+8) GO TO 888 SMAX=G14B02(TMAX,VMAX) SMIN=G14B02(TMIN,VMIN) IF (S.LT.SMIN .OR. S.GT.SMAX) GOTO 999 IF ( P.LT..07199 .OR. P.GT.13.152) GOTO 5 YT=G3B02(P) CALL S1B02(YT,VL,VG) SD=G14B02(YT,VL) SDD=SD+1D5*(VG-VL)*G2B02(P,YT)/YT IF (S.LT.SD) THEN TA=YT TB=TMIN ELSEIF (S.LE.SDD) THEN T=YT V=VL+(VG-VL)*(S-SD)/(SDD-SD) RETURN ELSE TA=TMAX TB=YT ENDIF GOTO 10 5 TA=TMAX TB=TMIN 10 VA=G10B02(P,TA) VB=G10B02(P,TB) IF (VA.LT.-1.E+8.OR.VB.LT.-1.E+8) GO TO 888 SA=G14B02(TA,VA) SB=G14B02(TB,VB) DSA=S-SA DSB=S-SB DSAB=SA-SB TC=TB+(TA-TB)*.5 VC=G10B02(P,TC) IF (VC.LT.-1.E+8) GO TO 888 SC=G14B02(TC,VC) DSC=S-SC IF (DSA*DSC.LE.0.0 .AND. DSB*DSC.GT.0.0) THEN TA=TA TB=TC ELSEIF (DSA*DSC.GT.0.0 .AND. DSB*DSC.LE.0.0) THEN TA=TC TB=TB ELSE GOTO 777 ENDIF 777 ILOOP=ILOOP+1 IF (ILOOP.GT.10000) GOTO 888 IF (DABS(TA-TB)/TB.GT.1E-6) GOTO 10 T=TC V=G10B02(P,T) RETURN 888 T=-1E10 V=-1E10 RETURN 999 T=-1E20 V=-1E20 RETURN END CS04 ****** IDEAL STATE CONDITION *********************** SUBROUTINE S4B02(T,AHT0,ST0,CP0) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(15),A1(5) DATA (A(I),I=1,13)/-0.2125426D5,0.6563535D4,-0.1746736D3, &0.1435630D5,0.2037489D2,-0.1293364D0,0.1148663D-1, &0.1636415D-3,-0.3768369D-5,0.4398648D4,0.60D2, &-0.4169621D5,-0.1570020D5/ DATA A1(1)/5.5401635898D0/,A1(2)/-0.02841312908D0/, &A1(3)/4.2035725898D-4/,A1(4)/-1.739896765D-6/, &A1(5)/2.363495322D-9/ IF (T.LT.273.15) GOTO 10 TT=T/100.0D0 U=A(11)/TT UI=DEXP(U) AHT0=-A(1)/2.0D0/TT**2-A(2)/TT+A(4)*TT+A(5)*TT**2/2.0D0 &+A(6)*TT**3/3.0D0+A(7)*TT**4/4.0D0+A(8)*TT**5/5.0D0 &+A(9)*TT**6/6.0D0+A(3)*DLOG(TT)+A(10)*A(11)/(UI-1.0D0) &+A(12) AHT0=AHT0*100.0D0 AHT0=AHT0+42.015D5 ST0=-A(1)/3.0D0/TT**3-A(2)/TT**2/2.0D0-A(3)/TT+A(5)*TT &+A(6)*TT**2/2.0D0+A(7)*TT**3/3.0D0+A(8)*TT**4/4.0D0 &+A(9)*TT**5/5.0D0+A(4)*DLOG(TT)+A(10)*(U*UI/(UI-1.0D0) &-DLOG(UI-1.0D0))+A(13) ST0=ST0+7.0537D4 CP0=A(1)/TT**3+A(2)/TT**2+A(3)/TT+A(4)+A(5)*TT+A(6)*TT**2 &+A(7)*TT**3+A(8)*TT**4+A(9)*TT**5+A(10)*U**2*UI/(UI-1.0D0)**2 RETURN 10 AHT0=6.3045D5 ST0=3.24023D4 T0=10D0 IF (T.LE.38D0) GOTO 20 SAM=4.9849D0*(38D0-T0) DH=(T-T0)/1000D0 TT=38D0 30 CONTINUE CPM=A1(1)+A1(2)*TT+A1(3)*TT**2+A1(4)*TT**3+A1(5)*TT**4 SAM=SAM+CPM*DH IF(TT.GT.T) GOTO 40 TT=TT+DH CP0=SAM/(TT-T0)*4.1855D0/2.016D0*1D3 GOTO 30 20 CP0=4.9849D0*4.1855D0/2.016D0*1D3 40 AHT0=AHT0+CP0*(T-T0) ST0=ST0+CP0*DLOG(T/T0) 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