C ************************************* C * PROPATH FOR HGK * C * * C * CODED (FEBRUARY 1988) * C * REVISED (MARCH 1989) * C * VERSION 7.1 * C * REVISED (MARCH 1990) * C * VERSION 8.1 * C * REVISED (AUGUST 1991) * C * * C * BY * C * TOMOHIRO HONDA * C * (FUKUOKA UNIVERSITY) * C * FUKUOKA 814-01, JAPAN * C ************************************* C ************************************* C * SUPERVISOR FOR HGK * C * CODED (FEBRUARY 1988) * C * REVISED (MARCH 1989) * C * REVISED (AUGUST 1991) * 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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(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 S99D04(FUN) WTDD=-1.0E+30 RETURN END C C==================================================================== C------------------------------------------------- F1 = AIPPT FUNCTION AIPPT(P,T) CHARACTER FUN*6 DATA FUN/'AIPPT'/ CALL S99D04(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=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL - FF = F94D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - AJTPT=FF RETURN END C------------------------------------------------- F82 = AKPT FUNCTION AKPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'AKPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F82D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AKPT=FF RETURN END C------------------------------------------------- F2 = ALAPP FUNCTION ALAPP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALAPP'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F2D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALAPP=FF RETURN END C------------------------------------------------- F3 = ALAPT FUNCTION ALAPT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALAPT'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F3D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALAPT=FF RETURN END C------------------------------------------------- F4 = ALHP FUNCTION ALHP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALHP'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F4D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALHP=FF RETURN END C------------------------------------------------- F5 = ALHT FUNCTION ALHT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALHT'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F5D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALHT=FF RETURN END C------------------------------------------------- F6 = ALMPD FUNCTION ALMPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALMPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F6D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMPD=FF RETURN END C------------------------------------------------- F7 = ALMPDD FUNCTION ALMPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALMPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F7D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMPDD=FF RETURN END C------------------------------------------------- F8 = ALMPT FUNCTION ALMPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'ALMPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F8D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMPT=FF RETURN END C------------------------------------------------- F9 = ALMTD FUNCTION ALMTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALMTD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F9D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMTD=FF RETURN END C------------------------------------------------- F10 = ALMTDD FUNCTION ALMTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALMTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F10D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMTDD=FF RETURN END C------------------------------------------------- F11 = AMUPD FUNCTION AMUPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'AMUPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F11D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUPD=FF RETURN END C------------------------------------------------- F12 = AMUPDD FUNCTION AMUPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'AMUPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F12D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUPDD=FF RETURN END C------------------------------------------------- F13 = AMUPT FUNCTION AMUPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'AMUPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F13D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUPT=FF RETURN END C------------------------------------------------- F14 = AMUTD FUNCTION AMUTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'AMUTD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F14D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUTD=FF RETURN END C------------------------------------------------- F15 = AMUTDD FUNCTION AMUTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'AMUTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F15D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUTDD=FF 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=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL - FF = F90D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL - FF = F91D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL - FF = F92D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL - FF = F93D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - BVPT=FF RETURN END C------------------------------------------------- F16 = CPPD FUNCTION CPPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CPPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F16D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPPD=FF RETURN END C------------------------------------------------- F17 = CPPDD FUNCTION CPPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CPPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F17D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPPDD=FF RETURN END C------------------------------------------------- F18 = CPPT FUNCTION CPPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'CPPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F18D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPPT=FF RETURN END C------------------------------------------------- F19 = CPTD FUNCTION CPTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'CPTD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F19D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPTD=FF RETURN END C------------------------------------------------- F20 = CPTDD FUNCTION CPTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'CPTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F20D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPTDD=FF RETURN END C------------------------------------------------- F21 = CRP 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 = F21D04(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 ', & ' WATER(IAPS 1984) WHEN A=',A,' ****') CRP=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- IF(A.EQ.'T') THEN T0K=-G99D04(0.0) FF=FF+T0K ELSE IF(A.EQ.'P') THEN PBAR=G98D04(1.0) FF=FF/PBAR END IF CRP=FF RETURN END C------------------------------------------------- F76 = CVPDD FUNCTION CVPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CVPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F76D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CVPDD=FF RETURN END C------------------------------------------------- F77 = CVPT FUNCTION CVPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'CVPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F77D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CVPT=FF RETURN END C------------------------------------------------- F78 = CVTDD FUNCTION CVTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'CVTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F78D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CVTDD=FF RETURN END C------------------------------------------------- F22 = EPSPT FUNCTION EPSPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'EPSPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F22D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- EPSPT=FF 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='18.0152' WHEN A='M' C B='461.52' WHEN A='R' C************************************************ FUNCTION FC(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'M') THEN FC=18.0152 ELSE IF (A.EQ.'R') THEN FC=461.52 ELSE FC=-1.E+20 IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT FC FOR WATER(IAPS 1984) WHEN A=''' & //A//''' ****' 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=G98D04(P) C--- FUNCTION CALL - FF = F96D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL - FF = F95D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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=G99D04(T) C--- FUNCTION CALL - FF = F97D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - GAMTDD=FF RETURN END C------------------------------------------------- F23 = HPD FUNCTION HPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'HPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F23D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPD=FF RETURN END C------------------------------------------------- F24 = HPDD FUNCTION HPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'HPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F24D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPDD=FF RETURN END C------------------------------------------------- F71 = HPS FUNCTION HPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'HPS'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F71D04(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPS=FF RETURN END C------------------------------------------------- F25 = HPT FUNCTION HPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'HPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F25D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPT=FF RETURN END C------------------------------------------------- F26 = HPX FUNCTION HPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'HPX'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F26D04(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPX=FF RETURN END C------------------------------------------------- F27 = HTD FUNCTION HTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F27D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HTD=FF RETURN END C------------------------------------------------- F28 = HTDD FUNCTION HTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F28D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HTDD=FF RETURN END C------------------------------------------------- F29 = HTX FUNCTION HTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTX'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F29D04(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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='WATER(IAPS 1984)' WHEN A='S' C B='H2O' 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='WATER(IAPS 1984)' ELSE IF (A.EQ.'C') THEN IDENTF='H2O' ELSE IF (A.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT IDENTF FOR H2O(IAPS 1984) WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F66 = PLDT FUNCTION PLDT(T) CHARACTER FUN*6 DATA FUN/'PLDT'/ CALL S99D04(FUN) PLDT=-1.0E+30 RETURN END C------------------------------------------------- F68 = PMLT FUNCTION PMLT(T) CHARACTER FUN*6 DATA FUN/'PMLT'/ CALL S99D04(FUN) PMLT=-1.0E+30 RETURN END C------------------------------------------------- F85 = PRPD FUNCTION PRPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'PRPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F85D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRPD=FF RETURN END C------------------------------------------------- F86 = PRPDD FUNCTION PRPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'PRPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F86D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRPDD=FF RETURN END C------------------------------------------------- F81 = PRPT FUNCTION PRPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'PRPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F81D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'PRTD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F87D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRTD=FF RETURN END C------------------------------------------------- F88 = PRTDD FUNCTION PRTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'PRTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F88D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRTDD=FF RETURN END C------------------------------------------------- F99 = PSBT FUNCTION PSBT(T) CHARACTER FUN*6 DATA FUN/'PSBT'/ CALL S99D04(FUN) PSBT=-1.0E+30 RETURN END C------------------------------------------------- F30 = PST FUNCTION PST(T) CHARACTER FUN*6 REAL PBAR,T,FF C--- FUNCTION NAME -- DATA FUN/'PST'/ C--- SET OF UNIT -- PBAR=G98D04(1.0) TI=G99D04(T) C--- FUNCTION CALL -- FF = F30D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) PST=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) PST=-1.0E+20 RETURN 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 S99D04(FUN) PSTD=-1.0E+30 RETURN END C------------------------------------------------- F73 = PSTDD FUNCTION PSTDD(T) CHARACTER FUN*6 DATA FUN/'PSTDD'/ CALL S99D04(FUN) PSTDD=-1.0E+30 RETURN END C------------------------------------------------- F31 = SIGP FUNCTION SIGP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SIGP'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F31D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSEIF (FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SIGP=FF RETURN END C------------------------------------------------- F32 = SIGT FUNCTION SIGT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'SIGT'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F32D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF (FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSEIF (FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SIGT=FF RETURN END C------------------------------------------------- F33 = SPD FUNCTION SPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F33D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPD=FF RETURN END C------------------------------------------------- F34 = SPDD FUNCTION SPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F34D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPDD=FF RETURN END C------------------------------------------------- F35 = SPT FUNCTION SPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'SPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F35D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPT=FF RETURN END C------------------------------------------------- F36 = SPX FUNCTION SPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'SPX'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F36D04(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPX=FF RETURN END C------------------------------------------------- F37 = STD FUNCTION STD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F37D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- STD=FF RETURN END C------------------------------------------------- F38 = STDD FUNCTION STDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F38D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- STDD=FF RETURN END C------------------------------------------------- F39 = STX FUNCTION STX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STX'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F39D04(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(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 S99D04(FUN) TLDP=-1.0E+30 RETURN END C------------------------------------------------- F69 = TMLP FUNCTION TMLP(P) CHARACTER FUN*6 DATA FUN/'TMLP'/ CALL S99D04(FUN) TMLP=-1.0E+30 RETURN END C------------------------------------------------- F64 = TPH FUNCTION TPH(P,H) CHARACTER FUN*6 REAL T0K,P,H,FF C--- FUNCTION NAME -- DATA FUN/'TPH'/ C--- SET OF UNIT -- PI=G98D04(P) T0K=-G99D04(0.0) C--- FUNCTION CALL -- FF = F64D04(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) TPH=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,H,'P','H',FUN) TPH=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPH=FF+T0K RETURN END C------------------------------------------------- F98 = TPSEUP FUNCTION TPSEUP(P) CHARACTER FUN*6 DATA FUN/'TPSEUP'/ CALL S99D04(FUN) TPSEUP=-1.0E+30 RETURN END C------------------------------------------------- F65 = TPS FUNCTION TPS(P,S) CHARACTER FUN*6 REAL T0K,P,S,FF C--- FUNCTION NAME -- DATA FUN/'TPS'/ C--- SET OF UNIT -- PI=G98D04(P) T0K=-G99D04(T) C--- FUNCTION CALL -- FF = F65D04(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) TPS=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,S,'P','S',FUN) TPS=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPS=FF+T0K RETURN END C------------------------------------------------- F70 = TPV FUNCTION TPV(P,V) CHARACTER FUN*6 REAL T0K,P,V,FF C--- FUNCTION NAME -- DATA FUN/'TPV'/ C--- SET OF UNIT -- PI=G98D04(P) T0K=-G99D04(0.0) C--- FUNCTION CALL -- FF = F70D04(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) TPV=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,V,'P','V',FUN) TPV=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPV=FF+T0K RETURN END C------------------------------------------------- F41 = TRPL FUNCTION TRPL(A) CHARACTER FUN*6,A*1 REAL T0K,PBAR,FF C--- FUNCTION NAME -- DATA FUN/'TRPL'/ C--- SET OF UNIT -- C--- FUNCTION CALL -- FF = F41D04(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 ', & ' WATER(IAPS 1984) WHEN A=',A,' ****') TRPL=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- IF(A.EQ.'T') THEN T0K=-G99D04(0.0) FF=FF+T0K ELSE IF(A.EQ.'P') THEN PBAR=G98D04(1.0) FF=FF/PBAR END IF TRPL=FF RETURN END C------------------------------------------------- F100 = TSBP FUNCTION TSBP(P) CHARACTER FUN*6 DATA FUN/'TSBP'/ CALL S99D04(FUN) TSBP=-1.0E+30 RETURN END C------------------------------------------------- F40 = TSP FUNCTION TSP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'TSP'/ C--- SET OF UNIT -- PI=G98D04(P) T0K=-G99D04(0.0) C--- FUNCTION CALL -- FF = F40D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) TSP=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) TSP=-1.0E+20 RETURN 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 S99D04(FUN) TSPD=-1.0E+30 RETURN END C------------------------------------------------- F75 = TSPDD FUNCTION TSPDD(P) CHARACTER FUN*6 DATA FUN/'TSPDD'/ CALL S99D04(FUN) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F42 = UPD FUNCTION UPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'UPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F42D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPD=FF RETURN END C------------------------------------------------- F43 = UPDD FUNCTION UPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'UPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F43D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPDD=FF RETURN END C------------------------------------------------- F79 = UPS FUNCTION UPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'UPS'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F79D04(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPS=FF RETURN END C------------------------------------------------- F44 = UPT FUNCTION UPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'UPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F44D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPT=FF RETURN END C------------------------------------------------- F45 = UPX FUNCTION UPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'UPX'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F45D04(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPX=FF RETURN END C------------------------------------------------- F46 = UTD FUNCTION UTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F46D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTD=FF RETURN END C------------------------------------------------- F47 = UTDD FUNCTION UTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F47D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTDD=FF RETURN END C------------------------------------------------- F48 = UTX FUNCTION UTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTX'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F48D04(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTX=FF RETURN END C------------------------------------------------- F49 = VPD FUNCTION VPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'VPD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F49D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPD=FF RETURN END C------------------------------------------------- F50 = VPDD FUNCTION VPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'VPDD'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F50D04(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPDD=FF RETURN END C------------------------------------------------- F80 = VPS FUNCTION VPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'VPS'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F80D04(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPS=FF RETURN END C------------------------------------------------- F51 = VPT FUNCTION VPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'VPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F51D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPT=FF RETURN END C------------------------------------------------- F52 = VPX FUNCTION VPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'VPX'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F52D04(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPX=FF RETURN END C------------------------------------------------- F53 = VTD FUNCTION VTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F53D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTD=FF RETURN END C------------------------------------------------- F54 = VTDD FUNCTION VTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTDD'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F54D04(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTDD=FF RETURN END C------------------------------------------------- F55 = VTX FUNCTION VTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTX'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F55D04(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTX=FF RETURN END C------------------------------------------------- F83 = WPT FUNCTION WPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'WPT'/ C--- SET OF UNIT -- PI=G98D04(P) TI=G99D04(T) C--- FUNCTION CALL -- FF = F83D04(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- WPT=FF RETURN END C------------------------------------------------- F56 = XPH FUNCTION XPH(P,H) CHARACTER FUN*6 REAL P,H,FF C--- FUNCTION NAME -- DATA FUN/'XPH'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F56D04(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,H,'P','H',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPH=FF RETURN END C------------------------------------------------- F57 = XPS FUNCTION XPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'XPS'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F57D04(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPS=FF RETURN END C------------------------------------------------- F58 = XPU FUNCTION XPU(P,U) CHARACTER FUN*6 REAL P,U,FF C--- FUNCTION NAME -- DATA FUN/'XPU'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F58D04(PI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,U,'P','U',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPU=FF RETURN END C------------------------------------------------- F59 = XPV FUNCTION XPV(P,V) CHARACTER FUN*6 REAL P,V,FF C--- FUNCTION NAME -- DATA FUN/'XPV'/ C--- SET OF UNIT -- PI=G98D04(P) C--- FUNCTION CALL -- FF = F59D04(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,P,V,'P','V',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPV=FF RETURN END C------------------------------------------------- F60 = XTH FUNCTION XTH(T,H) CHARACTER FUN*6 REAL T,H,FF C--- FUNCTION NAME -- DATA FUN/'XTH'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F60D04(TI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,T,H,'T','H',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTH=FF RETURN END C------------------------------------------------- F61 = XTS FUNCTION XTS(T,S) CHARACTER FUN*6 REAL T,S,FF C--- FUNCTION NAME -- DATA FUN/'XTS'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F61D04(TI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,T,S,'T','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTS=FF RETURN END C------------------------------------------------- F62 = XTU FUNCTION XTU(T,U) CHARACTER FUN*6 REAL T,U,FF C--- FUNCTION NAME -- DATA FUN/'XTU'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F62D04(TI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,T,U,'T','U',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTU=FF RETURN END C------------------------------------------------- F63 = XTV FUNCTION XTV(T,V) CHARACTER FUN*6 REAL T,V,FF C--- FUNCTION NAME -- DATA FUN/'XTV'/ C--- SET OF UNIT -- TI=G99D04(T) C--- FUNCTION CALL -- FF = F63D04(TI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D04(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D04(3,T,V,'T','V',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTV=FF RETURN END C------------------------------------------------- G98 C *** FUNCTION FOR SETTING UNITS **** FUNCTION G98D04(P) REAL P,G98D04 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 G98D04=REAL(DBLE(P)*PBAR) RETURN END C------------------------------------------------- G99 FUNCTION G99D04(T) REAL T,G99D04 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 G99D04=REAL(DBLE(T)-T0K) RETURN END C------------------------------------------------- S97 C *** LEVEL 1 ERROR MESSAGE -- SUBROUTINE S97D04(FUN) CHARACTER FLUID*16,FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA FLUID/'WATER(IAPS 1984)'/ IF (MESS.NE.0) THEN WRITE(6,1000) FUN,FLUID 1000 FORMAT(1H ,5X,'**** NO CONVERGENCE AT ',A6,' FOR ', & A16,' ****') ENDIF RETURN END C------------------------------------------------- S98 C *** LEVEL 2 ERROR MESSAGE -- SUBROUTINE S98D04(IPT,P,T,N1,N2,FUN) CHARACTER FLUID*16,FUN*6,N1*1,N2*1 REAL P,T INTEGER KPA,MESS,IPT COMMON/UNIT/KPA,MESS DATA FLUID/'WATER(IAPS 1984)'/ 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 ',A16, & ' 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 ',A16, & ' 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 ',A16, & ' WHEN ',A1,'=',1PE14.7,' AND ',A1,'=',1PE14.7,' ****') ENDIF ENDIF RETURN END C------------------------------------------------- S99 C *** LEVEL 3 ERROR MESSAGE -- SUBROUTINE S99D04(FUN) CHARACTER FLUID*16,FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA FLUID/'WATER(IAPS 1984)'/ IF (MESS.NE.0) THEN WRITE(6,1000) FUN,FLUID 1000 FORMAT(1H ,5X,'**** FUNCTION ',A6,' UNAVAILABLE FOR ', & A16,' ****') ENDIF RETURN END C ***************************************** C * FUNCTION PROGRAMS OF WATER(IAPS 1984) * C * * C * PROGRAM NAME HGKFUN VER.3.1 * C * FOR PROPATH VER.6.1 * C * * C * CODED (FEB. 1987) * C * REVISED (FEB. 1988) * C * REVISED (MAR. 1989) * C * * C * REVISED AND F90-F97 WAS APPENDED * C * FOR PROPATH VERSION 8.1 * C * (AUGUST 1991) * C * * C * BY * C * TOMOHIRO HONDA * C * FUKUOKA UNIVERSITY * C * FUKUOKA, 814-01, JAPAN * C ***************************************** C F02 + LAPLACE COEFFICIENT AT P FUNCTION F2D04(P) INTEGER G91D04 IG91=G91D04(P) IF (IG91.EQ.0) THEN T=F40D04(P) F2D04=F3D04(T) ELSEIF (IG91.EQ.1) THEN F2D04=0.0 ELSE F2D04=-1.0E+20 ENDIF RETURN END C F03 + LAPLACE COEFFICIENT AT T FUNCTION F3D04(T) IMPLICIT DOUBLE PRECISION (Y) INTEGER G92D04 IG92=G92D04(T) IF (IG92.EQ.0) THEN YT=DBLE(T+273.15) CALL S8D04(YT,YP,YRG,YRL) IF (YRG.EQ.YRL) THEN F3D04=0.0 ELSE RV=REAL(YRL-YRG)*1.0E+03 T=REAL(YT)-273.15 SIG=G16D04(T) F3D04=SQRT(SIG/RV/9.80665) ENDIF ELSEIF (IG92.EQ.1) THEN F3D04=0.0 ELSE F3D04=-1.0E+20 ENDIF RETURN END C F04 + LATENT HEAT OF VAPORIZATION AT P FUNCTION F4D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F4D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) YHL=G63D04(YTS,YRL) YHG=G63D04(YTS,YRG) F4D04=REAL(YHG-YHL)*1.0E+03 ENDIF RETURN END C F05 + LATENT HEAT OF VAPORIZATION AT T FUNCTION F5D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F5D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) YHL=G63D04(YT,YRL) YHG=G63D04(YT,YRG) F5D04=REAL(YHG-YHL)*1.0E+03 ENDIF RETURN END C F06 + LUMDA OF SATURATED LIQUID AT P FUNCTION F6D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) F6D04=REAL(G11D04(YTS,YRL)) ELSE F6D04=-1.0E+20 ENDIF RETURN END C F07 + LUMDA OF SATURATED VAPOR AT P FUNCTION F7D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) F7D04=REAL(G11D04(YTS,YRG)) ELSE F7D04=-1.0E+20 ENDIF RETURN END C F08 + LUMDA AT P AND T FUNCTION F8D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (P.LT.6.11731E-3) GOTO 999 IF (P.GT.1000) GOTO 999 IF (T.LT.0) GOTO 999 IF (T.GT.800) GOTO 999 IF (G93D04(P,T).EQ.1) GOTO 999 YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) F8D04=REAL(G11D04(YT,YRO)) RETURN 999 F8D04=-1.0E+20 RETURN END C F09 + LUMDA OF SATURATED LIQUID AT T FUNCTION F9D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F9D04=REAL(G11D04(YT,YRL)) ELSE F9D04=-1.0E+20 ENDIF RETURN END C F10 + LUMDA OF SATURATED VAPOR AT T FUNCTION F10D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F10D04=REAL(G11D04(YT,YRG)) ELSE F10D04=-1.0E+20 ENDIF RETURN END C F11 + MYU OF SATURATED LIQUID AT P FUNCTION F11D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F11D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) F11D04=REAL(G10D04(YTS,YRL)) ENDIF RETURN END C F12 + MYU OF SATURATED VAPOR AT P FUNCTION F12D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F12D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) F12D04=REAL(G10D04(YTS,YRG)) ENDIF RETURN END C F13 + MYU AT P AND T FUNCTION F13D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (P.LT.6.11731E-3) GOTO 999 IF (P.GT.1000) GOTO 999 IF (T.LT.0) GOTO 999 IF (T.GT.800) GOTO 999 YP=DBLE(P*0.1) YT=DBLE(T+273.15) IF (G93D04(P,T).EQ.1) THEN YRO=0.322D+00 ELSE YRO=G1D04(YP,YT) ENDIF F13D04=REAL(G10D04(YT,YRO)) RETURN 999 F13D04=-1.0E+20 RETURN END C F14 + MYU OF SATURATED LIQUID AT T FUNCTION F14D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F14D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F14D04=REAL(G10D04(YT,YRL)) ENDIF RETURN END C F15 + MYU OF SATURATED VAPOR AT T FUNCTION F15D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F15D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F15D04=REAL(G10D04(YT,YRG)) ENDIF RETURN END C F16 + CP OF SATURATED LIQUID AT P FUNCTION F16D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) YDT=DABS(YTS-647.126D0) IF (YDT .LT. 0.5D0) THEN F16D04=-1.0E+20 ELSE F16D04=REAL(G9D04(YTS,YRL))*1.0E+03 ENDIF ELSE F16D04=-1.0E+20 ENDIF RETURN END C F17 + CP OF SATURATED VAPOUR AT P FUNCTION F17D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) YDT=DABS(YTS-647.126D0) IF (YDT .LT. 0.5D0) THEN F17D04=-1.0E+20 ELSE F17D04=REAL(G9D04(YTS,YRG))*1.0E+03 ENDIF ELSE F17D04=-1.0E+20 ENDIF RETURN END C F18 + CP AT P AND T FUNCTION F18D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.2) THEN YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G1D04(YP,YT) F18D04=REAL(G9D04(YT,YR))*1.0E3 ELSE F18D04=-1.0E+20 ENDIF RETURN END C F19 + CP OF SATURATED LIQUID AT T FUNCTION F19D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN DT=ABS(T-373.976) IF (DT .LT. 0.5) THEN F19D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F19D04=REAL(G9D04(YT,YRL))*1.0E+03 ENDIF ELSE F19D04=-1.0E+20 ENDIF RETURN END C F20 + CP OF SATURATED VAPOUR AT T FUNCTION F20D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN DT=ABS(T-373.976) IF (DT .LT. 0.5) THEN F20D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F20D04=REAL(G9D04(YT,YRG))*1.0E+03 ENDIF ELSE F20D04=-1.0E+20 ENDIF RETURN END C F21 + CRITICAL POINT FUNCTION F21D04(A) CHARACTER*1 A IF (A.EQ.'H') THEN F21D04=2.086E6 ELSEIF (A.EQ.'P') THEN F21D04=220.55 ELSEIF (A.EQ.'S') THEN F21D04=4.409E3 ELSEIF (A.EQ.'T') THEN F21D04=373.976 ELSEIF (A.EQ.'V') THEN F21D04=1E0/322 ELSE F21D04=-1.0E+20 ENDIF RETURN END C F22 + STATISTIC DIELECTRIC CONSTANT<-> AT P & T FUNCTION F22D04(P,T) IF (P.GT.5E3 .OR. T.GT.550) GOTO 999 VV=F51D04(P,T) IF (VV.LT.0) GOTO 999 RO=1.0E-03/VV TK=T+273.15 F22D04=G15D04(TK,RO) RETURN 999 F22D04=-1.0E+20 RETURN END C F23 + H OF SATURATED LIQUID AT P FUNCTION F23D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F23D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YU0=-1.997677535D3 CALL S9D04(YP,YTS,YRG,YRL) YHH=G63D04(YTS,YRL) F23D04=REAL(YHH-YU0)*1.0E+03 ENDIF RETURN END C F24 + H OF SATURATED VAPOUR AT P FUNCTION F24D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F24D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YU0=-1.997677535D3 CALL S9D04(YP,YTS,YRG,YRL) YHH=G63D04(YTS,YRG) F24D04=REAL(YHH-YU0)*1.0E+03 ENDIF RETURN END C F25 + H AT P AND T FUNCTION F25D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IG=G93D04(P,T) IF (IG.EQ.1) THEN F25D04=0.2085776E+07 ELSEIF (IG.EQ.2) THEN YP=DBLE(P*0.1) YT=DBLE(T+273.15) YU0=-1.997677535D3 YRO=G1D04(YP,YT) YHH=G63D04(YT,YRO) F25D04=REAL(YHH-YU0)*1.0E+03 ELSE F25D04=-1.0E+20 ENDIF RETURN END C F26 + H OF MIXTURE AT P FUNCTION F26D04(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (X.GE.0.0) THEN IF(X.LE.1.0) THEN IF (G91D04(P).LE.1) THEN YP=DBLE(P*0.1) YX=DBLE(X) YU0=-1.997677535D3 CALL S9D04(YP,YTS,YRG,YRL) YHL=G63D04(YTS,YRL) YHG=G63D04(YTS,YRG) F26D04=REAL(YHL+YX*(YHG-YHL)-YU0)*1.0E+03 RETURN ENDIF ENDIF ENDIF F26D04=-1.0E+20 RETURN END C F27 + H OF SATURATED LIQUID AT T FUNCTION F27D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F27D04=-1.0E+20 ELSE YT=DBLE(T+273.15) YU0=-1.997677535D3 CALL S8D04(YT,YPS,YRG,YRL) YHH=G63D04(YT,YRL) F27D04=REAL(YHH-YU0)*1.0E+03 ENDIF RETURN END C F28 + H OF SATURATED VAPOUR AT T FUNCTION F28D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F28D04=-1.0E+20 ELSE YT=DBLE(T+273.15) YU0=-1.997677535D3 CALL S8D04(YT,YPS,YRG,YRL) YHH=G63D04(YT,YRG) F28D04=REAL(YHH-YU0)*1.0E+03 ENDIF RETURN END C F29 + H OF MIXTURE AT T FUNCTION F29D04(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (X.GE.0.0) THEN IF(X.LE.1.0) THEN IF (G92D04(T).LE.1) THEN YT=DBLE(T+273.15) YX=DBLE(X) YU0=-1.997677535D3 CALL S8D04(YT,YPS,YRG,YRL) YHL=G63D04(YT,YRL) YHG=G63D04(YT,YRG) F29D04=REAL(YHL+YX*(YHG-YHL)-YU0)*1.0E+03 RETURN ENDIF ENDIF ENDIF F29D04=-1.0E+20 RETURN END C F30 + SATURATION PRESSURE AT T FUNCTION F30D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F30D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YP,YRG,YRL) F30D04=REAL(YP)*1E1 ENDIF RETURN END C F31 + SURFACE TENSION AT P FUNCTION F31D04(P) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F31D04=-1.0E+20 ELSE T=F40D04(P) F31D04=G16D04(T) ENDIF RETURN END C F32 + SURFACE TENSION AT T FUNCTION F32D04(T) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F32D04=-1.0E+20 ELSE F32D04=G16D04(T) ENDIF RETURN END C F33 + S OF SATURATED LIQUID AT P FUNCTION F33D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F33D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YS0=3.515905565D0 CALL S9D04(YP,YTS,YRG,YRL) YSS=G61D04(YTS,YRL) F33D04=REAL(YSS-YS0)*1.0E+03 ENDIF RETURN END C F34 + S OF SATURATED VAPOUR AT P FUNCTION F34D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F34D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YS0=3.515905565D0 CALL S9D04(YP,YTS,YRG,YRL) YSS=G61D04(YTS,YRG) F34D04=REAL(YSS-YS0)*1.0E+03 ENDIF RETURN END C F35 + S AT P AND T FUNCTION F35D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IG=G93D04(P,T) IF (IG.EQ.1) THEN F35D04=0.440905E+04 ELSEIF (IG.EQ.2) THEN YP=DBLE(P*0.1) YT=DBLE(T+273.15) YS0=3.515905565D0 YRO=G1D04(YP,YT) YSS=G61D04(YT,YRO) F35D04=REAL(YSS-YS0)*1.0E+03 ELSE F35D04=-1.0E+20 ENDIF RETURN END C F36 + S OF MIXTURE AT P FUNCTION F36D04(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (X.GE.0.0) THEN IF (X.LE.1.0) THEN IF (G91D04(P).LE.1) THEN YP=DBLE(P*0.1) YX=DBLE(X) YS0=3.515905565D0 CALL S9D04(YP,YTS,YRG,YRL) YSL=G61D04(YTS,YRL) YSG=G61D04(YTS,YRG) F36D04=REAL(YSL+YX*(YSG-YSL)-YS0)*1.0E+03 RETURN ENDIF ENDIF ENDIF F36D04=-1.0E+20 RETURN END C F37 + S OF SATURATED LIQUID AT T FUNCTION F37D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F37D04=-1.0E+20 ELSE YT=DBLE(T+273.15) YS0=3.515905565D0 CALL S8D04(YT,YPS,YRG,YRL) YSS=G61D04(YT,YRL) F37D04=REAL(YSS-YS0)*1.0E+03 ENDIF RETURN END C F38 + S OF SATURATED VAPOUR AT T FUNCTION F38D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F38D04=-1.0E+20 ELSE YT=DBLE(T+273.15) YS0=3.515905565D0 CALL S8D04(YT,YPS,YRG,YRL) YSS=G61D04(YT,YRG) F38D04=REAL(YSS-YS0)*1.0E+03 ENDIF RETURN END C F39 + S OF MIXTURE AT T FUNCTION F39D04(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (X.GE.0.0) THEN IF (X.LE.1.0) THEN IF (G92D04(T).LE.1) THEN YT=DBLE(T+273.15) YX=DBLE(X) YS0=3.515905565D0 CALL S8D04(YT,YPS,YRG,YRL) YSL=G61D04(YT,YRL) YSG=G61D04(YT,YRG) F39D04=REAL(YSL+YX*(YSG-YSL)-YS0)*1.0E+03 RETURN ENDIF ENDIF ENDIF F39D04=-1.0E+20 RETURN END C F40 + SATURATION TEMPERATURE AT P FUNCTION F40D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F40D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YT,YRG,YRL) F40D04=REAL(YT)-273.15 ENDIF RETURN END C F41 + TRIPLE POINT FUNCTION F41D04(A) CHARACTER*1 A IF (A.EQ.'P') THEN F41D04=6.11731E-3 ELSEIF (A.EQ.'T') THEN F41D04=0.01 ELSE F41D04=-1.0E+20 ENDIF RETURN END C F42 + U OF SATURATED LIQUID AT P FUNCTION F42D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F42D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YU0=-1.997677535D3 CALL S9D04(YP,YTS,YRG,YRL) YUU=G62D04(YTS,YRL) F42D04=REAL(YUU-YU0)*1.0E+03 ENDIF RETURN END C F43 + U OF SATURATED VAPOUR AT P FUNCTION F43D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F43D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YU0=-1.997677535D3 CALL S9D04(YP,YTS,YRG,YRL) YUU=G62D04(YTS,YRG) F43D04=REAL(YUU-YU0)*1.0E+03 ENDIF RETURN END C F44 + U AT P AND T FUNCTION F44D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IG=G93D04(P,T) IF (IG.EQ.1) THEN F44D04=0.201728E+07 ELSEIF (IG.EQ.2) THEN YP=DBLE(P*0.1) YT=DBLE(T+273.15) YU0=-1.997677535D3 YRO=G1D04(YP,YT) YUU=G62D04(YT,YRO) F44D04=REAL(YUU-YU0)*1.0E+03 ELSE F44D04=-1.0E+20 ENDIF RETURN END C F45 + U OF MIXTURE AT P FUNCTION F45D04(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (X.GE.0.0) THEN IF (X.LE.1.0) THEN IF (G91D04(P).LE.1) THEN YP=DBLE(P*0.1) YX=DBLE(X) YU0=-1.997677535D3 CALL S9D04(YP,YTS,YRG,YRL) YUL=G62D04(YTS,YRL) YUG=G62D04(YTS,YRG) F45D04=REAL(YUL+YX*(YUG-YUL)-YU0)*1.0E+03 RETURN ENDIF ENDIF ENDIF F45D04=-1.0E+20 RETURN END C F46 + U OF SATURATED LIQUID AT T FUNCTION F46D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F46D04=-1.0E+20 ELSE YT=DBLE(T+273.15) YU0=-1.997677535D3 CALL S8D04(YT,YPS,YRG,YRL) YUU=G62D04(YT,YRL) F46D04=REAL(YUU-YU0)*1.0E+03 ENDIF RETURN END C F47 + U OF SATURATED VAPOUR AT T FUNCTION F47D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F47D04=-1.0E+20 ELSE YT=DBLE(T+273.15) YU0=-1.997677535D3 CALL S8D04(YT,YPS,YRG,YRL) YUU=G62D04(YT,YRG) F47D04=REAL(YUU-YU0)*1.0E+03 ENDIF RETURN END C F48 + U OF MIXTURE AT T FUNCTION F48D04(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (X.GE.0.0) THEN IF (X.LE.1.0) THEN IF (G92D04(T).LE.1) THEN YT=DBLE(T+273.15) YX=DBLE(X) YU0=-1.997677535D3 CALL S8D04(YT,YPS,YRG,YRL) YUL=G62D04(YT,YRL) YUG=G62D04(YT,YRG) F48D04=REAL(YUL+YX*(YUG-YUL)-YU0)*1.0E+03 RETURN ENDIF ENDIF ENDIF F48D04=-1.0E+20 RETURN END C F49 + V OF SATURATED LIQUID AT P FUNCTION F49D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F49D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YT,YRG,YRL) F49D04=1E-3/REAL(YRL) ENDIF RETURN END C F50 + V OF SATURATED GAS AT P FUNCTION F50D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F50D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YT,YRG,YRL) F50D04=1E-3/REAL(YRG) ENDIF RETURN END C F51 + V AT P AND T FUNCTION F51D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.3) THEN F51D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=DBLE(T+273.15) F51D04=1E-3/REAL(G1D04(YP,YT)) ENDIF RETURN END C F52 + V OF MIXTURE AT P FUNCTION F52D04(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (X.GE.0.0) THEN IF (X.LE.1.0) THEN IF (G91D04(P).LE.1) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YT,YRG,YRL) VG=1E-3/REAL(YRG) VL=1E-3/REAL(YRL) F52D04=VL+X*(VG-VL) RETURN ENDIF ENDIF ENDIF F52D04=-1.0E+20 RETURN END C F53 + V OF SATURATED LIQUID AT T FUNCTION F53D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F53D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YP,YRG,YRL) F53D04=1E-3/REAL(YRL) ENDIF RETURN END C F54 + V OF SATURATED GAS AT T FUNCTION F54D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F54D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YP,YRG,YRL) F54D04=1E-3/REAL(YRG) ENDIF RETURN END C F55 + V OF MIXTURE AT T FUNCTION F55D04(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (X.GE.0.0) THEN IF (X.LE.1.0) THEN IF (G92D04(T).LE.1) THEN YT=DBLE(T+273.15) CALL S8D04(YT,YP,YRG,YRL) VL=1E-3/REAL(YRL) VG=1E-3/REAL(YRG) F55D04=VL+X*(VG-VL) RETURN ENDIF ENDIF ENDIF F55D04=-1.0E+20 RETURN END C F56 + DRYNESS FRACTION <-> AT P,H FUNCTION F56D04(P,H) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN T=F40D04(P) F56D04=F60D04(T,H) ELSE F56D04=-1.0E+20 ENDIF RETURN END C F57 + DRYNESS FRACTION <-> AT P,S FUNCTION F57D04(P,S) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN T=F40D04(P) F57D04=F61D04(T,S) ELSE F57D04=-1.0E+20 ENDIF RETURN END C F58 + DRYNESS FRACTION <-> AT P,U FUNCTION F58D04(P,U) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN T=F40D04(P) F58D04=F62D04(T,U) ELSE F58D04=-1.0E+20 ENDIF RETURN END C F59 + DRYNESS FRACTION <-> AT P,V FUNCTION F59D04(P,V) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN T=F40D04(P) F59D04=F63D04(T,V) ELSE F59D04=-1.0E+20 ENDIF RETURN END C F60 + DRYNESS FRACTION <-> AT T,H FUNCTION F60D04(T,H) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN HD=F27D04(T) HDD=F28D04(T) IF (HD.NE.HDD) THEN IF (H.GE.HD) THEN IF (H.LE.HDD) THEN F60D04=(H-HD)/(HDD-HD) RETURN ENDIF ENDIF ENDIF ENDIF F60D04=-1.0E+20 RETURN END C F61 + DRYNESS FRACTION <-> AT T,S FUNCTION F61D04(T,S) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN SD=F37D04(T) SDD=F38D04(T) IF (SD.NE.SDD) THEN IF (S.GE.SD) THEN IF (S.LE.SDD) THEN F61D04=(S-SD)/(SDD-SD) RETURN ENDIF ENDIF ENDIF ENDIF F61D04=-1.0E+20 RETURN END C F62 + DRYNESS FRACTION <-> AT T,U FUNCTION F62D04(T,U) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN UD=F46D04(T) UDD=F47D04(T) IF (UD.NE.UDD) THEN IF (U.GE.UD) THEN IF (U.LE.UDD) THEN F62D04=(U-UD)/(UDD-UD) RETURN ENDIF ENDIF ENDIF ENDIF F62D04=-1.0E+20 RETURN END C F63 + DRYNESS FRACTION <-> AT T,V FUNCTION F63D04(T,V) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN YT=DBLE(T+273.15) CALL S8D04(YT,YP,YRG,YRL) VL=1E-3/REAL(YRL) VG=1E-3/REAL(YRG) IF (VL.NE.VG) THEN IF (V.GE.VL) THEN IF (V.LE.VG) THEN F63D04=(V-VL)/(VG-VL) RETURN ENDIF ENDIF ENDIF ENDIF F63D04=-1.0E+20 RETURN END C F64 + TEMPERATURE AT P AND H FUNCTION F64D04(P,H) DOUBLE PRECISION PP,HH,TT,RR,SS,UU PP=DBLE(P*0.1) HH=DBLE(H*1E-3)-1.997677535D3 CALL S10D04(PP,HH,TT,RR,SS,UU) T=REAL(TT) IF (T.GE.-1.0) THEN F64D04=T-273.15 ELSE F64D04=T ENDIF RETURN END C F65 + TEMPERATURE AT P AND S FUNCTION F65D04(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P*0.1) SS=DBLE(S*1E-3)+3.515905565D0 CALL S11D04(PP,SS,TT,RR,HH,UU) T=REAL(TT) IF (T.GE.-1.0) THEN F65D04=T-273.15 ELSE F65D04=T ENDIF RETURN END C F70 + TEMPERATURE AT P AND V FUNCTION F70D04(P,V) IMPLICIT DOUBLE PRECISION (G,Y) YP=DBLE(P)*1.0D-01 YR=1D-3/DBLE(V) T=REAL(G5D04(YP,YR)) IF (T.GE.-1.0) THEN F70D04=T-273.15 ELSE F70D04=T ENDIF RETURN END C F71 + H AT P AND S FUNCTION F71D04(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P*0.1) SS=DBLE(S*1E-3)+3.515905565D0 CALL S11D04(PP,SS,TT,RR,HH,UU) H=REAL(HH) IF (H.GE.-1E8) THEN F71D04=REAL(HH+1.997677535D3)*1.0E+03 ELSE F71D04=H ENDIF RETURN END C FA1 + CV OF SATURATED LIQUID AT P FUNCTION FA1D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN FA1D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) FA1D04=REAL(G18D04(YTS,YRL))*1.0E+03 ENDIF RETURN END C F76 + CV OF SATURATED VAPOUR AT P FUNCTION F76D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.3) THEN F76D04=-1.0E+20 ELSE YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) F76D04=REAL(G18D04(YTS,YRG))*1.0E+03 ENDIF RETURN END C F77 + CV AT P AND T FUNCTION F77D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.3) THEN F77D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) F77D04=REAL(G18D04(YT,YRO))*1.0E+03 ENDIF RETURN END C FA2 + CV OF SATURATED LIQUID AT T FUNCTION FA2D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN FA2D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) FA2D04=REAL(G18D04(YT,YRL))*1.0E+03 ENDIF RETURN END C F78 + CV OF SATURATED VAPOUR AT T FUNCTION F78D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.3) THEN F78D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F78D04=REAL(G18D04(YT,YRG))*1.0E+03 ENDIF RETURN END C F79 + U AT P AND S FUNCTION F79D04(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P*0.1) SS=DBLE(S*1E-3)+3.515905565D0 CALL S11D04(PP,SS,TT,RR,HH,UU) U=REAL(UU) IF (U.GE.-1E8) THEN F79D04=REAL(UU+1.997677535D3)*1.0E+03 ELSE F79D04=U ENDIF RETURN END C F80 + V AT P AND S FUNCTION F80D04(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH,UU PP=DBLE(P*0.1) SS=DBLE(S*1E-3)+3.515905565D0 CALL S11D04(PP,SS,TT,RR,HH,UU) R=REAL(RR) IF (R.GE.-1E8) THEN F80D04=1E-3/R ELSE F80D04=R ENDIF RETURN END C F81 + PR<-> AT P AND T FUNCTION F81D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (P.LT.6.11731E-3) GOTO 999 IF (T.LT.0) GOTO 999 IF (T.GT.800) GOTO 999 IF (P.GT.1000) GOTO 999 IF (G93D04(P,T).EQ.1) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YRO=G1D04(YP,YT) F81D04=REAL(G20D04(YT,YRO)) RETURN 999 F81D04=-1.0E+20 RETURN END C F82 + KAPPA<-> AT P AND T FUNCTION F82D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.3) THEN F82D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) F82D04=REAL(G22D04(YT,YRO)) ENDIF RETURN END C F83 + W AT P AND T FUNCTION F83D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.3) THEN F83D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) F83D04=REAL(G24D04(YT,YRO)) ENDIF RETURN END C F85 + PRPD(P) FUNCTION F85D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) YDT=DABS(YTS-647.126D0) IF (YDT .LT. 0.5D0) THEN F85D04=-1.0E+20 ELSE F85D04=REAL(G20D04(YTS,YRL)) ENDIF ELSE F85D04=-1.0E+20 ENDIF RETURN END C F86 + PRPDD(P) FUNCTION F86D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) YDT=DABS(YTS-647.126D0) IF (YDT .LT. 0.5D0) THEN F86D04=-1.0E+20 ELSE F86D04=REAL(G20D04(YTS,YRG)) ENDIF ELSE F86D04=-1.0E+20 ENDIF RETURN END C F87 + PRTD(T) FUNCTION F87D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN DT=ABS(T-373.976) IF (DT .LT. 0.5) THEN F87D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F87D04=REAL(G20D04(YT,YRL)) ENDIF ELSE F87D04=-1.0E+20 ENDIF RETURN END C F88 + PRTDD(T) FUNCTION F88D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN DT=ABS(T-373.976) IF (DT .LT. 0.5) THEN F88D04=-1.0E+20 ELSE YT=DBLE(T+273.15) CALL S8D04(YT,YPS,YRG,YRL) F88D04=REAL(G20D04(YT,YRG)) ENDIF ELSE F88D04=-1.0E+20 ENDIF RETURN END C F90 + BSPT<1/PA> AT P AND T FUNCTION F90D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.3) THEN F90D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) YSS=G24D04(YT,YRO) YV=1.0D-03/YRO F90D04=REAL(YV/YSS**2) ENDIF RETURN END C F91 + BTPT<1/PA> AT P AND T FUNCTION F91D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.2) THEN YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) YDPDR=G65D04(YT,YRO) F91D04=1.0E-06/REAL(YRO*YDPDR) ELSE F91D04=-1.0E+20 ENDIF RETURN END C F92 + BPPT<1/K> AT P AND T FUNCTION F92D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.2) THEN YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) YDPDR=G65D04(YT,YRO) YDPDT=G66D04(YT,YRO) F92D04=REAL(YDPDT/(YRO*YDPDR)) ELSE F92D04=-1.0E+20 ENDIF RETURN END C F93 + BVPT<1/K> AT P AND T FUNCTION F93D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.3) THEN F93D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) YDPDT=G66D04(YT,YRO) F93D04=REAL(YDPDT/YP) ENDIF RETURN END C F94 + AJTPT AT P AND T FUNCTION F94D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.3) THEN F94D04=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) YDPDR=G65D04(YT,YRO) YDPDT=G66D04(YT,YRO) YCP=G9D04(YT,YRO) YY=YT*YDPDT/(YRO*YDPDR) F94D04=1.0E-06*REAL((YY-1.0D+00)/(YRO*YCP)) ENDIF RETURN END C F95 + RATIO OF SPECIFIC HEATS AT P AND T FUNCTION F95D04(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D04 IF (G93D04(P,T).EQ.2) THEN YP=DBLE(P*0.1) YT=DBLE(T+273.15) YRO=G1D04(YP,YT) F95D04=REAL(G9D04(YT,YRO)/G18D04(YT,YRO)) ELSE F95D04=-1.0E+20 ENDIF RETURN END C F96 + RATIO OF SPECIFIC HEATS OF SATURATED VAPOUR AT P BAR FUNCTION F96D04(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D04 IF (G91D04(P).EQ.0) THEN YP=DBLE(P*0.1) CALL S9D04(YP,YTS,YRG,YRL) YDT=DABS(YTS-647.126D0) IF (YDT .LT. 0.5D0) THEN F96D04=-1.0E+20 ELSE F96D04=REAL(G9D04(YTS,YRG)/G18D04(YTS,YRG)) ENDIF ELSE F96D04=-1.0E+20 ENDIF RETURN END C F97 + RATIO OF SPECIFIC HEATS OF SATURATED VAPOUR AT T FUNCTION F97D04(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D04 IF (G92D04(T).EQ.0) THEN YT=DBLE(T+273.15) YDT=DABS(YT-647.126D0) IF (YDT .LT. 0.5D0) THEN F97D04=-1.0E+20 ELSE CALL S8D04(YT,YPS,YRG,YRL) F97D04=REAL(G9D04(YT,YRG)/G18D04(YT,YRG)) ENDIF ELSE F97D04=-1.0E+20 ENDIF RETURN END C ********************************* C * HGK PROPERTIES VER.3.1 * C * PRESSURE * C * TEMPERATURE * C * DENSITY * C * ENTHALPY * C * ENTROPY * C ********************************* C G01 *** DENSITY AT P & T FUNCTION G1D04(P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,RCR,TCR/22.055D+00,0.322D+00,647.126D+00/ DPCR=DABS(P/PCR-1.0D+00) IF (DPCR.LT.1.0D-05) THEN DTCR=DABS(T/TCR-1.0D+00) IF (DTCR.LT.1.0D-05) THEN G1D04=RCR RETURN ENDIF ENDIF IF (T.GT.647.126D0) THEN RMAX=1.3D0 RMIN=1D-10 ELSE CALL S8D04(T,PS,ROG,ROL) IF (P.GT.PS) THEN RMAX=1.4D0 RMIN=ROL ELSE RMAX=ROG RMIN=1D-10 ENDIF ENDIF RST1=G3D04(RMAX,RMIN,P,T) G1D04=G2D04(P,T,RST1) RETURN END C G02 *** DENSITY BY NEWTON-METHOD C C *** AT P & T:R1=INITIAL VALUE FUNCTION G2D04(P,T,R1) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 10 P1=G60D04(T,R1) DPDRO1=G65D04(T,R1) R2=(P-P1)/DPDRO1+R1 ILOOP=ILOOP+1 IF (ILOOP.EQ.1000) THEN G2D04=-1.0E+10 ELSEIF (DABS((R2-R1)/R2).LT.1.0D-07) THEN G2D04=R2 ELSE R1=R2 GOTO 10 ENDIF RETURN END C G03 *** DETERMINATION OF INITIAL VALUE C C *** RO, P, T FUNCTION G3D04(RMAX,RMIN,P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 RA=RMAX RB=RMIN PA=G60D04(T,RA) PB=G60D04(T,RB) 10 DPA=P-PA DPB=P-PB RC=RB+(RA-RB)*0.5D+00 PC=G60D04(T,RC) DPC=P-PC IF (DPA*DPC.LE.0.0 .AND. DPB*DPC.GT.0.0) THEN RB=RC PB=PC ELSEIF (DPA*DPC.GT.0.0 .AND. DPB*DPC.LE.0.0) THEN RA=RC PA=PC ELSE RA=1.1*RA RB=0.9*RB PA=G60D04(T,RA) PB=G60D04(T,RB) ENDIF ILOOP=ILOOP+1 IF (ILOOP.EQ.10000) THEN G3D04=-1.0E+10 ELSEIF (DABS(RA-RB)/RB.GT.1.0D-02) THEN GOTO 10 ELSE G3D04=RC ENDIF RETURN END C G05 *** TEMPERATURE FROM P AND RO FUNCTION G5D04(P,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PCR,RCR,TCR/22.055D+00,0.322D+00,647.126D+00/ IF (P.LT.6.11731D-4 .OR. P.GT.1.5D3) GOTO 999 DPPC=DABS(P/PCR-1.0D+00) IF (DPPC.LT.1.0D-05) THEN DRRC=DABS(RO/RCR-1.0D+00) IF (DRRC.LT.1.0D-05) THEN G5D04=TCR RETURN ENDIF ENDIF IF (P.LE.5D2) THEN TMIN=273.15D0 ELSE TMIN=(P/1D2-5D0)*15+273.15D0 ENDIF TMAX=1273.15D0 RMAX=G1D04(P,TMAX) RMIN=G1D04(P,TMIN) IF (RO.LT.RMAX .OR. RO.GT.RMIN) GOTO 999 IF (P.GT.22.055D0) THEN IF (RO.LT.RCR) THEN TA=TMAX RA=RMAX TB=TCR RB=RCR ELSE TA=TCR RA=RCR TB=TMIN RB=RMIN ENDIF ELSE CALL S9D04(P,T,RG,RL) IF (RO.GT.RL) THEN TA=T RA=RL TB=TMIN RB=RMIN ELSEIF (RO.GE.RG) THEN G5D04=T RETURN ELSE TA=TMAX RA=RMAX TB=T RB=RG ENDIF ENDIF ILOOP=0 10 DRA=RO-RA DRB=RO-RB T=TB+(TA-TB)*0.5D+00 RST1=G3D04(RB,RA,P,T) RC=G2D04(P,T,RST1) 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 ILOOP=ILOOP+1 IF (ILOOP.EQ.10000) THEN G5D04=-1.0E+10 ELSEIF (DABS((RA-RB)/RO).GT.1.0D-07) THEN GOTO 10 ELSE G5D04=T ENDIF RETURN 999 G5D04=-1.0E+20 RETURN END C G09 *** CP AT T & RO FUNCTION G9D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PB=G33D04(T,RO) DPBDR=G34D04(T,RO) DPBDT=G35D04(T,RO) DABDTT=G36D04(T,RO) RS1DTT=G43D04(T,RO) RS2DTT=G53D04(T,RO) RS1DR=G44D04(T,RO) RS2DR=G54D04(T,RO) RS1DRR=G45D04(T,RO) RS2DRR=G55D04(T,RO) RS1DRT=G46D04(T,RO) RS2DRT=G56D04(T,RO) DAIDTT=G59D04(T) RO2=RO*RO PP=PB+RO2*(RS1DR+RS2DR) DADTT=DABDTT+RS1DTT+RS2DTT+DAIDTT CV=-T*DADTT DPDT=DPBDT+RO2*(RS1DRT+RS2DRT) DPDR=DPBDR+2D0*(PP-PB)/RO+RO2*(RS1DRR+RS2DRR) G9D04=CV+T/RO2*DPDT**2/DPDR RETURN END C G10 *** DYNAMIC VISCOSITY AT T & RO FUNCTION G10D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A0,A1/1.81583D-2, 1.77624D-2/ DATA A2,A3/1.05287D-2, -3.6744D-3/ DATA B00,B01,B02,B03,B04,B10,B11,B12,B13,B14, & B20,B21,B22,B23,B24,B30,B31,B32,B33,B34, & B40,B41,B42,B43,B44,B50,B51,B52,B53,B54/ & .501938D0, .235622D0,-.274637D0, .145831D0,-.0270488D0, & .162888D0, .789393D0,-.743539D0, .263129D0,-.0253093D0, &-.130356D0, .673665D0,-.959456D0, .347247D0,-.0267758D0, & .907919D0,1.207552D0,-.687343D0, .213486D0,-.0822904D0, &-.551119D0,.0670665D0,-.497089D0, .100754D0, .0602253D0, & .146543D0,-.0843370D0,.195286D0,-.032932D0,-.0202595D0/ ROASTA=.317763D0 TASTA=647.27D0 TR=TASTA/T RR=RO/ROASTA AMU0=TR*(TR*(A3*TR+A2)+A1)+A0 AMU0=DSQRT(T/TASTA)/AMU0*1D-6 X=TR-1D0 Y=RR-1D0 EX=Y*(Y*(Y*(B04*Y+B03)+B02)+B01)+B00 XX=X EX=EX+(Y*(Y*(Y*(B14*Y+B13)+B12)+B11)+B10)*XX XX=XX*X EX=EX+(Y*(Y*(Y*(B24*Y+B23)+B22)+B21)+B20)*XX XX=XX*X EX=EX+(Y*(Y*(Y*(B34*Y+B33)+B32)+B31)+B30)*XX XX=XX*X EX=EX+(Y*(Y*(Y*(B44*Y+B43)+B42)+B41)+B40)*XX XX=XX*X EX=EX+(Y*(Y*(Y*(B54*Y+B53)+B52)+B51)+B50)*XX AMUEX=DEXP(RR*EX) G10D04=AMU0*AMUEX RETURN END C G11 *** THERMAL CONDUCTIVITY AT T & RO FUNCTION G11D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A0,A1/2.02223D0,14.11166D0/ DATA A2,A3/5.25597D0,-2.01870D0/ DATA B00,B10,B20,B30,B40,B01,B11,B21,B31,B41, & B02,B12,B22,B32,B03,B13,B23,B33, & B04,B14,B24,B05,B15,B25/ & 1.3293046D0, 1.7018363D0, 5.2246158D0, & 8.7127675D0, -1.8525999D0, &-0.40452437D0,-2.2156845D0,-10.124111D0, &-9.5000611D0, 0.93404690D0, & 0.24409490D0, 1.6511057D0, 4.9874687D0, 4.3786606D0, & 1.8660751D-2,-0.76736002D0,-0.27297694D0,-0.91783782D0, &-0.12961068D0, 0.37283344D0,-0.43083393D0, & 4.4809953D-2,-0.11203160D0, 0.13333849D0/ TASTA=647.27D0 ROASTA=.317763D0 PASTA=22.115D0 C=3.7711D-8 PASTA=22.115D0 OMEGA=0.4678D0 A=18.66D0 TR=TASTA/T RR=RO/ROASTA RAM0=TR*(TR*(A3*TR+A2)+A1)+A0 RAM0=DSQRT(T/TASTA)/RAM0 X=TR-1D0 Y=RR-1D0 EY=X*(X*(X*(B40*X+B30)+B20)+B10)+B00 YY=Y EY=EY+(X*(X*(X*(B41*X+B31)+B21)+B11)+B01)*YY YY=YY*Y EY=EY+(X*(X*(B32*X+B22)+B12)+B02)*YY YY=YY*Y EY=EY+(X*(X*(B33*X+B23)+B13)+B03)*YY YY=YY*Y EY=EY+(X*(B24*X+B14)+B04)*YY YY=YY*Y EY=EY+(X*(B25*X+B15)+B05)*YY RAMEY=DEXP(RR*EY) RAM0EY=RAM0*RAMEY XR=T/TASTA-1D0 DD=-A*XR*XR-Y**4 DDEX=DEXP(DD) DPDR=G65D04(T,RO) DPDT=G66D04(T,RO) AKAIT=RR*PASTA/ROASTA/DPDR IF (AKAIT .LT.0D0) AKAIT=0D0 ADPDT2=((TASTA/PASTA)*DPDT)**2 AMU=G10D04(T,RO) DELTA=C/AMU/(TR*RR)**2*ADPDT2*AKAIT**OMEGA DELTA=DELTA*DSQRT(RR)*DDEX G11D04=RAM0EY+DELTA RETURN END C G15 *** STATISTIC DIELECTRIC CONSTANT AT T & RO FUNCTION G15D04(T,RO) DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10/ & 7.62571E0, 2.44003E2,-1.40569E2, 2.77841E1,-9.62805E1, & 4.17909E1,-1.02099E1,-4.52059E1, 8.46395E1,-3.58644E1/ TA=T/298.15E0 S=1E0+A1/TA*RO S=S+(A2/TA+A3+A4*TA)*RO**2 S=S+(A5/TA+(A6+A7*TA)*TA)*RO**3 G15D04=S+((A8/TA+A9)/TA+A10)*RO**4 RETURN END C G16 *** SURFACE TENSION AT T FUNCTION G16D04(T) TK=T+273.15 TR=1E0-TK/647.15 SIG1=TR**1.256 SIG2=1E0-.625*TR SIG=.2358*SIG1*SIG2 IF (SIG.LT.1E-6) SIG=0 G16D04=SIG RETURN END C G18 *** CV AT T & RO FUNCTION G18D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PB=G33D04(T,RO) DABDTT=G36D04(T,RO) RS1DTT=G43D04(T,RO) RS2DTT=G53D04(T,RO) RS1DR=G44D04(T,RO) RS2DR=G54D04(T,RO) DAIDTT=G59D04(T) RO2=RO*RO PP=PB+RO2*(RS1DR+RS2DR) DADTT=DABDTT+RS1DTT+RS2DTT+DAIDTT G18D04=-T*DADTT RETURN END C G20 *** PR<-> AT T & RO FUNCTION G20D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) G20D04=G9D04(T,RO)*1.0E3*G10D04(T,RO)/G11D04(T,RO) RETURN END C G22 *** KAPPA<-> AT T & RO FUNCTION G22D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PP=G60D04(T,RO) DPDR=G65D04(T,RO) G22D04=G9D04(T,RO)*DPDR/G18D04(T,RO)*RO/PP RETURN END C G23 *** KAPPA I=0 (P,T):I=1(T,J):I=2(P,J):J=1(GAS):J=2(LIQ) FUNCTION G23D04(P,T,I,J) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (I.EQ.0) THEN RO=G1D04(P,T) G23D04=G22D04(T,RO) ELSE IF (I.EQ.1) THEN CALL S8D04(T,PS,RG,RL) TS=T ELSEIF (I.EQ.2) THEN CALL S9D04(P,TS,RG,RL) ENDIF IF (J.EQ.1) THEN G23D04=G22D04(TS,RG) ELSEIF (J.EQ.2) THEN G23D04=G22D04(TS,RL) ENDIF ENDIF RETURN END C G24 *** SPEED OF SOUND AT T & RO FUNCTION G24D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DPDR=G65D04(T,RO) WWW=G9D04(T,RO)*DPDR/G18D04(T,RO)*1D3 G24D04=DSQRT(WWW) RETURN END C G25 *** SOUND SPEED I=0 (P,T):I=1(T,J):I=2(P,J):J=1(GAS):J=2(LIQ) FUNCTION G25D04(P,T,I,J) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (I.EQ.0) THEN RO=G1D04(P,T) G25D04=G24D04(T,RO) ELSE IF (I.EQ.1) THEN CALL S8D04(T,PS,RG,RL) TS=T ELSEIF (I.EQ.2) THEN CALL S9D04(P,TS,RG,RL) ENDIF IF (J.EQ.1) THEN G25D04=G24D04(TS,RG) ELSEIF (J.EQ.2) THEN G25D04=G24D04(TS,RL) ENDIF ENDIF RETURN END C G26 *** BS : FUNCTIONS OF T FUNCTION G26D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA BS0,BS1,BS3,BS5 1 / 7.478629D-1, -3.540782D-1, 7.159876D-3, 2 -3.528426D-3/ T0=647.073D0 TR=T0/T TR2=TR*TR TR3=TR2*TR G26D04=BS0+BS1*DLOG(1.D0/TR)+(BS3+BS5*TR2)*TR3 RETURN END C G27 *** DBSDT : FUNCTIONS OF T FUNCTION G27D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA BS1,BS3,BS5 1 /-3.540782D-1, 7.159876D-3, -3.528426D-3/ T0=647.073D0 TR=T0/T TR2=TR*TR TR3=TR2*TR G27D04=(BS1-(3*BS3+5*BS5*TR2)*TR3)/T RETURN END C G28 *** DBSDTT : FUNCTIONS OF T FUNCTION G28D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA BS1,BS3,BS5 1 /-3.540782D-1, 7.159876D-3, -3.528426D-3/ T0=647.073D0 TR=T0/T TR2=TR*TR TR3=TR2*TR G28D04=((30*BS5*TR2+12*BS3)*TR3-BS1)/T/T RETURN END C G29 *** BL : FUNCTIONS OF T FUNCTION G29D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA BL0,BL1,BL2,BL4 1 / 1.1278334D0,-5.944001D-1, -5.010996D0, 2 6.3684256D-1/ T0=647.073D0 TR=T0/T TR2=TR*TR G29D04=BL0+(BL1+(BL2+BL4*TR2)*TR)*TR RETURN END C G30 *** DBLDT : FUNCTIONS OF T FUNCTION G30D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA BL1,BL2,BL4 1 / -5.944001D-1, -5.010996D0, 6.3684256D-1/ T0=647.073D0 TR=T0/T TR2=TR*TR DBLDT=(BL1+(2*BL2+4*BL4*TR2)*TR)*TR/T G30D04=-DBLDT RETURN END C G31 *** DBLDTT : FUNCTIONS OF T FUNCTION G31D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA BL1,BL2,BL4 1 / -5.944001D-1, -5.010996D0, 6.3684256D-1/ T0=647.073D0 TR=T0/T TR2=TR*TR G31D04=(2*BL1+(6*BL2+20*BL4*TR2)*TR)*TR/T/T RETURN END C G32 *** AB : HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G32D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X AB=-DLOG(X)-(CG2-1D0)/X+(CG1+CG2+1D0)/2/X2 AB=AB+4*Y*(BLS-CG3)-(CG1-CG2+3)/2 AB=AB+DLOG(RO*GASCON*T/P0) G32D04=GASCON*T*AB RETURN END C G33 *** PB : HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G33D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X Z1=(1+CG1*Y+CG2*Y*Y)/X3 Z=Z1+4*Y*(BLS-CG3) G33D04=RO*GASCON*T*Z RETURN END C G34 *** DPBDRO:HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G34D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X Z1=(1+CG1*Y+CG2*Y*Y)/X3 Z=Z1+4*Y*(BLS-CG3) DZ1DY=(CG1+2*CG2*Y)/X3+3*Z1/X ZDPDR=Z+BS*RO*(0.25D0*DZ1DY-CG3)+BL*RO G34D04=GASCON*T*ZDPDR RETURN END C G35 *** DPBDT:HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G35D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X Z1=(1+CG1*Y+CG2*Y*Y)/X3 Z=Z1+4*Y*(BLS-CG3) DZ1DY=(CG1+2*CG2*Y)/X3+3*Z1/X DBSDT=G27D04(T) DBLDT=G30D04(T) ZDPDT=Z+RO*T*(DBSDT*(.25D0*DZ1DY-CG3)+DBLDT) G35D04=RO*GASCON*ZDPDT RETURN END C G36 *** DABDTT:HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G36D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X Z1=(1+CG1*Y+CG2*Y*Y)/X3 Z=Z1+4*Y*(BLS-CG3) DZ1DY=(CG1+2*CG2*Y)/X3+3*Z1/X DBSDT=G27D04(T) DBLDT=G30D04(T) UB0=DBSDT*(Z1-1D0-4D0*Y*CG3)/BS+RO*DBLDT+1D0/T DBBB=(DBSDT/BS)**2 DBSDTT=G28D04(T) DBLDTT=G31D04(T) UB1=(Z1-1D0)*(DBSDTT/BS-DBBB) UB2=RO*(DBLDTT-CG3*DBSDTT) UB3=DBBB*Y*DZ1DY G36D04=(2D0*UB0-1D0/T+T*(UB1+UB2+UB3))*GASCON RETURN END C G37 *** UB:HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G37D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X Z1=(1+CG1*Y+CG2*Y*Y)/X3 DBSDT=G27D04(T) DBLDT=G30D04(T) UB0=DBSDT*(Z1-1D0-4D0*Y*CG3)/BS+RO*DBLDT+1D0/T G37D04=-GASCON*T*T*UB0 RETURN END C G38 *** SB:HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G38D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) UB=G37D04(T,RO) AB=G32D04(T,RO) G38D04=(UB-AB)/T RETURN END C G39 *** HB:HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G39D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X Z1=(1+CG1*Y+CG2*Y*Y)/X3 Z=Z1+4*Y*(BLS-CG3) UB=G37D04(T,RO) G39D04=UB+GASCON*T*Z RETURN END C G40 *** GB:HELMHOLTZ FUNCTION (BASE) AT T & RO FUNCTION G40D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CG1,CG3/11.D0,3.5D0/ CG2=133.D0/3.D0 GASCON=8.31441D0/1.80152D1 P0=1.01325D-1 BS=G26D04(T) BL=G29D04(T) BLS=BL/BS Y=BS*RO/4 X=1D0-Y X2=X*X X3=X2*X AB=-DLOG(X)-(CG2-1D0)/X+(CG1+CG2+1D0)/2/X2 AB=AB+4*Y*(BLS-CG3)-(CG1-CG2+3)/2 AB=AB+DLOG(RO*GASCON*T/P0) AB=GASCON*T*AB Z1=(1+CG1*Y+CG2*Y*Y)/X3 Z=Z1+4*Y*(BLS-CG3) G40D04=AB+GASCON*T*Z RETURN END C G41 *** AR:HELMHOLTZ FUNCTION (RESIDUAL 1) AT T & RO FUNCTION G41D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(36),K(36),L(36) DATA K/4*1,4*2,4*3,4*4,4*5,4*6,4*7,4*9,3,3,1,5/ DATA L/1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6, * 1,2,4,6,1,2,4,6,0,3,3,3/ DATA G/-5.3062968529023D2, 2.2744901424408D3, 7.8779333020687D2, 1-6.9830527374994D1, 1.7863832875422D4,-3.9514731563338D4, 2 3.3803884280753D4,-1.3855050202703D4,-2.5637436613260D5, 3 4.8212575981415D5,-3.4183016969660D5, 1.2223156417448D5, 4 1.1797433655832D6,-2.1734810110373D6, 1.0829952168620D6, 5-2.5441998064049D5,-3.1377774947767D6, 5.2911910757704D6, 6-1.3802577177877D6,-2.5109914369001D5, 4.6561826115608D6, 7-7.2752773275387D6, 4.1774246148294D5, 1.4016358244614D6, 8-3.1555231392127D6, 4.7929666384584D6, 4.0912664781209D5, 9-1.3626369388386D6, 6.9625220862664D5,-1.0834900096447D6, A-2.2722827401688D5, 3.8365486000660D5, 6.8833257944332D3, B 2.1757245522644D4,-2.6627944829770D3,-7.0730418082074D4/ T0=647.073D0 TR=T0/T A=1D0 EX=DEXP(-A*RO) YEX=1D0-EX AR=0D0 DO 10 I=1,36 KK=K(I) KK1=KK-1 KK2=KK-2 LL=L(I) GG=G(I) TRL=TR**LL YEXKK=YEX**KK AR=AR+GG/KK*TRL*YEXKK 10 CONTINUE G41D04=AR RETURN END C G42 *** DARDT:HELMHOLTZ FUNCTION (RESIDUAL 1) AT T & RO FUNCTION G42D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(36),K(36),L(36) DATA K/4*1,4*2,4*3,4*4,4*5,4*6,4*7,4*9,3,3,1,5/ DATA L/1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6, * 1,2,4,6,1,2,4,6,0,3,3,3/ DATA G/-5.3062968529023D2, 2.2744901424408D3, 7.8779333020687D2, 1-6.9830527374994D1, 1.7863832875422D4,-3.9514731563338D4, 2 3.3803884280753D4,-1.3855050202703D4,-2.5637436613260D5, 3 4.8212575981415D5,-3.4183016969660D5, 1.2223156417448D5, 4 1.1797433655832D6,-2.1734810110373D6, 1.0829952168620D6, 5-2.5441998064049D5,-3.1377774947767D6, 5.2911910757704D6, 6-1.3802577177877D6,-2.5109914369001D5, 4.6561826115608D6, 7-7.2752773275387D6, 4.1774246148294D5, 1.4016358244614D6, 8-3.1555231392127D6, 4.7929666384584D6, 4.0912664781209D5, 9-1.3626369388386D6, 6.9625220862664D5,-1.0834900096447D6, A-2.2722827401688D5, 3.8365486000660D5, 6.8833257944332D3, B 2.1757245522644D4,-2.6627944829770D3,-7.0730418082074D4/ T0=647.073D0 TR=T0/T A=1D0 EX=DEXP(-A*RO) YEX=1D0-EX DARDT=0D0 DO 10 I=1,36 KK=K(I) KK1=KK-1 KK2=KK-2 LL=L(I) GG=G(I) TRL=TR**LL YEXKK=YEX**KK DARDT=DARDT-GG/KK*LL*TRL*YEXKK 10 CONTINUE G42D04=DARDT/T RETURN END C G43 *** DARDTT:HELMHOLTZ FUNCTION (RESIDUAL 1) AT T & RO FUNCTION G43D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(36),K(36),L(36) DATA K/4*1,4*2,4*3,4*4,4*5,4*6,4*7,4*9,3,3,1,5/ DATA L/1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6, * 1,2,4,6,1,2,4,6,0,3,3,3/ DATA G/-5.3062968529023D2, 2.2744901424408D3, 7.8779333020687D2, 1-6.9830527374994D1, 1.7863832875422D4,-3.9514731563338D4, 2 3.3803884280753D4,-1.3855050202703D4,-2.5637436613260D5, 3 4.8212575981415D5,-3.4183016969660D5, 1.2223156417448D5, 4 1.1797433655832D6,-2.1734810110373D6, 1.0829952168620D6, 5-2.5441998064049D5,-3.1377774947767D6, 5.2911910757704D6, 6-1.3802577177877D6,-2.5109914369001D5, 4.6561826115608D6, 7-7.2752773275387D6, 4.1774246148294D5, 1.4016358244614D6, 8-3.1555231392127D6, 4.7929666384584D6, 4.0912664781209D5, 9-1.3626369388386D6, 6.9625220862664D5,-1.0834900096447D6, A-2.2722827401688D5, 3.8365486000660D5, 6.8833257944332D3, B 2.1757245522644D4,-2.6627944829770D3,-7.0730418082074D4/ T0=647.073D0 TR=T0/T A=1D0 EX=DEXP(-A*RO) YEX=1D0-EX DARDTT=0D0 DO 10 I=1,36 KK=K(I) KK1=KK-1 KK2=KK-2 LL=L(I) GG=G(I) TRL=TR**LL YEXKK=YEX**KK DARDTT=DARDTT+GG/KK*LL*(LL+1)*TRL*YEXKK 10 CONTINUE G43D04=DARDTT/T/T RETURN END C G44 *** DARDR:HELMHOLTZ FUNCTION (RESIDUAL 1) AT T & RO FUNCTION G44D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(36),K(36),L(36) DATA K/4*1,4*2,4*3,4*4,4*5,4*6,4*7,4*9,3,3,1,5/ DATA L/1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6, * 1,2,4,6,1,2,4,6,0,3,3,3/ DATA G/-5.3062968529023D2, 2.2744901424408D3, 7.8779333020687D2, 1-6.9830527374994D1, 1.7863832875422D4,-3.9514731563338D4, 2 3.3803884280753D4,-1.3855050202703D4,-2.5637436613260D5, 3 4.8212575981415D5,-3.4183016969660D5, 1.2223156417448D5, 4 1.1797433655832D6,-2.1734810110373D6, 1.0829952168620D6, 5-2.5441998064049D5,-3.1377774947767D6, 5.2911910757704D6, 6-1.3802577177877D6,-2.5109914369001D5, 4.6561826115608D6, 7-7.2752773275387D6, 4.1774246148294D5, 1.4016358244614D6, 8-3.1555231392127D6, 4.7929666384584D6, 4.0912664781209D5, 9-1.3626369388386D6, 6.9625220862664D5,-1.0834900096447D6, A-2.2722827401688D5, 3.8365486000660D5, 6.8833257944332D3, B 2.1757245522644D4,-2.6627944829770D3,-7.0730418082074D4/ T0=647.073D0 TR=T0/T A=1D0 EX=DEXP(-A*RO) YEX=1D0-EX DARDR=0D0 DO 10 I=1,36 KK=K(I) KK1=KK-1 KK2=KK-2 LL=L(I) GG=G(I) TRL=TR**LL YEXKK=YEX**KK DARDR=DARDR+GG*TRL*YEXKK/YEX*A*EX 10 CONTINUE G44D04=DARDR RETURN END C G45 *** DARDRR:HELMHOLTZ FUNCTION (RESIDUAL 1) AT T & RO FUNCTION G45D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(36),K(36),L(36) DATA K/4*1,4*2,4*3,4*4,4*5,4*6,4*7,4*9,3,3,1,5/ DATA L/1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6, * 1,2,4,6,1,2,4,6,0,3,3,3/ DATA G/-5.3062968529023D2, 2.2744901424408D3, 7.8779333020687D2, 1-6.9830527374994D1, 1.7863832875422D4,-3.9514731563338D4, 2 3.3803884280753D4,-1.3855050202703D4,-2.5637436613260D5, 3 4.8212575981415D5,-3.4183016969660D5, 1.2223156417448D5, 4 1.1797433655832D6,-2.1734810110373D6, 1.0829952168620D6, 5-2.5441998064049D5,-3.1377774947767D6, 5.2911910757704D6, 6-1.3802577177877D6,-2.5109914369001D5, 4.6561826115608D6, 7-7.2752773275387D6, 4.1774246148294D5, 1.4016358244614D6, 8-3.1555231392127D6, 4.7929666384584D6, 4.0912664781209D5, 9-1.3626369388386D6, 6.9625220862664D5,-1.0834900096447D6, A-2.2722827401688D5, 3.8365486000660D5, 6.8833257944332D3, B 2.1757245522644D4,-2.6627944829770D3,-7.0730418082074D4/ T0=647.073D0 TR=T0/T A=1D0 EX=DEXP(-A*RO) YEX=1D0-EX DARDRR=0D0 DO 10 I=1,36 KK=K(I) KK1=KK-1 KK2=KK-2 LL=L(I) GG=G(I) TRL=TR**LL YEXKK=YEX**KK DARDRR=DARDRR+GG*TRL*YEXKK/YEX/YEX*A*A*(KK*EX-1D0)*EX 10 CONTINUE G45D04=DARDRR RETURN END C G46 *** DARDRT:HELMHOLTZ FUNCTION (RESIDUAL 1) AT T & RO FUNCTION G46D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(36),K(36),L(36) DATA K/4*1,4*2,4*3,4*4,4*5,4*6,4*7,4*9,3,3,1,5/ DATA L/1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6,1,2,4,6, * 1,2,4,6,1,2,4,6,0,3,3,3/ DATA G/-5.3062968529023D2, 2.2744901424408D3, 7.8779333020687D2, 1-6.9830527374994D1, 1.7863832875422D4,-3.9514731563338D4, 2 3.3803884280753D4,-1.3855050202703D4,-2.5637436613260D5, 3 4.8212575981415D5,-3.4183016969660D5, 1.2223156417448D5, 4 1.1797433655832D6,-2.1734810110373D6, 1.0829952168620D6, 5-2.5441998064049D5,-3.1377774947767D6, 5.2911910757704D6, 6-1.3802577177877D6,-2.5109914369001D5, 4.6561826115608D6, 7-7.2752773275387D6, 4.1774246148294D5, 1.4016358244614D6, 8-3.1555231392127D6, 4.7929666384584D6, 4.0912664781209D5, 9-1.3626369388386D6, 6.9625220862664D5,-1.0834900096447D6, A-2.2722827401688D5, 3.8365486000660D5, 6.8833257944332D3, B 2.1757245522644D4,-2.6627944829770D3,-7.0730418082074D4/ T0=647.073D0 TR=T0/T A=1D0 EX=DEXP(-A*RO) YEX=1D0-EX DARDRT=0D0 DO 10 I=1,36 KK=K(I) KK1=KK-1 KK2=KK-2 LL=L(I) GG=G(I) TRL=TR**LL YEXKK=YEX**KK DARDRT=DARDRT-GG*LL*TRL*YEXKK/YEX*A*EX 10 CONTINUE G46D04=DARDRT/T RETURN END C G51 *** HELMHOLTZ FUNCTION (RESIDUAL 2) AT T & RO FUNCTION G51D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION K(4),RI(4),TI(4),AL(4),BE(4),G(4) DIMENSION DL(4),DLK(4),DLL(4),TA(4) DATA K/2,2,2,4/,RI/3*0.319D0,1.55D0/ DATA TI/2*640.D0,641.6D0,270D0/ DATA AL/34D0,40D0,30D0,1.050D3/,BE/2*2D4,4D4,2.5D1/ DATA G/-.225D0,-1.68D0,5.5D-2,-93.0D0/ DO 10 I=1,4 DL(I)=RO/RI(I)-1D0 TA(I)=T/TI(I)-1D0 DLK(I)=DL(I)**2 DLL(I)=1D0 10 CONTINUE DLK(4)=DLK(4)**2 DLL(2)=DL(2)**2 AR=0D0 DO 30 I=1,4 AR=AR+G(I)*DLL(I)*DEXP(-AL(I)*DLK(I)-BE(I)*TA(I)**2) 30 CONTINUE G51D04=AR RETURN END C G52 *** DARDT OF HELMHOLTZ FUNCTION (RESIDUAL 2) C *** AT T & RO FUNCTION G52D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION K(4),RI(4),TI(4),AL(4),BE(4),G(4) DIMENSION DL(4),DLK(4),DLL(4),TA(4) DATA K/2,2,2,4/,RI/3*0.319D0,1.55D0/ DATA TI/2*640.D0,641.6D0,270D0/ DATA AL/34D0,40D0,30D0,1.050D3/,BE/2*2D4,4D4,2.5D1/ DATA G/-.225D0,-1.68D0,5.5D-2,-93.0D0/ DO 10 I=1,4 DL(I)=RO/RI(I)-1D0 TA(I)=T/TI(I)-1D0 DLK(I)=DL(I)**2 DLL(I)=1D0 10 CONTINUE DLK(4)=DLK(4)**2 DLL(2)=DL(2)**2 DARDT=0D0 DO 30 I=1,4 BETA=BE(I) TAI=TA(I) CBTRT=BETA*TAI/TI(I) DARDT=DARDT+CBTRT*G(I)*DLL(I)*DEXP(-AL(I)*DLK(I)-BETA*TAI**2) 30 CONTINUE G52D04=-2D0*DARDT RETURN END C G53 *** DARDTT OF HELMHOLTZ FUNCTION (RESIDUAL 2) C *** AT T & RO FUNCTION G53D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION K(4),RI(4),TI(4),AL(4),BE(4),G(4) DIMENSION DL(4),DLK(4),DLL(4),TA(4) DATA K/2,2,2,4/,RI/3*0.319D0,1.55D0/ DATA TI/2*640.D0,641.6D0,270D0/ DATA AL/34D0,40D0,30D0,1.050D3/,BE/2*2D4,4D4,2.5D1/ DATA G/-.225D0,-1.68D0,5.5D-2,-93.0D0/ DO 10 I=1,4 DL(I)=RO/RI(I)-1D0 TA(I)=T/TI(I)-1D0 DLK(I)=DL(I)**2 DLL(I)=1D0 10 CONTINUE DLK(4)=DLK(4)**2 DLL(2)=DL(2)**2 DARDTT=0D0 DO 30 I=1,4 ALPHA=AL(I) BETA=BE(I) DLI=DL(I) DLKI=DLK(I) TII=TI(I) TAI=TA(I) CBTRT=BETA*TAI/TII EX=G(I)*DLL(I)*DEXP(-ALPHA*DLKI-BETA*TAI**2) DARDTT=DARDTT+EX*(2*CBTRT**2-BETA/(TII*TII)) 30 CONTINUE G53D04=2D0*DARDTT RETURN END C G54 *** DARDR OF HELMHOLTZ FUNCTION (RESIDUAL 2) C AT T & RO FUNCTION G54D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION K(4),RI(4),TI(4),AL(4),BE(4),G(4) DIMENSION DL(4),DLK(4),DLL(4),TA(4),TA2(4) DATA K/2,2,2,4/,RI/3*0.319D0,1.55D0/ DATA TI/2*640.D0,641.6D0,270D0/ DATA AL/34D0,40D0,30D0,1.050D3/,BE/2*2D4,4D4,2.5D1/ DATA G/-.225D0,-1.68D0,5.5D-2,-93.0D0/ DO 10 I=1,4 DL(I)=RO/RI(I)-1D0 TA(I)=T/TI(I)-1D0 DLK(I)=DL(I)**2 DLL(I)=1D0 TA2(I)=TA(I)**2 10 CONTINUE DLK(4)=DLK(4)**2 DLL(2)=DL(2)**2 DARDR=0D0 DO 30 I=1,4 ALPHA=AL(I) BETA=BE(I) DLI=DL(I) DLKI=DLK(I) TII=TI(I) CKARD=ALPHA/RI(I)*DLKI*K(I) EX=G(I)*DLL(I)*DEXP(-ALPHA*DLKI-BETA*TA2(I)) DARDR=DARDR+EX*CKARD/DLI 30 CONTINUE GGG38=G(2)*DL(2)*DEXP(-AL(2)*DLK(2)-BE(2)*TA2(2))/RI(2) G54D04=2D0*GGG38-DARDR RETURN END C G55 *** DARDRR OF HELMHOLTZ FUNCTION (RESIDUAL 2) C *** AT T & RO FUNCTION G55D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION K(4),RI(4),TI(4),AL(4),BE(4),G(4) DIMENSION DL(4),DLK(4),DLL(4),TA(4),TA2(4) DATA K/2,2,2,4/,RI/3*0.319D0,1.55D0/ DATA TI/2*640.D0,641.6D0,270D0/ DATA AL/34D0,40D0,30D0,1.050D3/,BE/2*2D4,4D4,2.5D1/ DATA G/-.225D0,-1.68D0,5.5D-2,-93.0D0/ DO 10 I=1,4 DL(I)=RO/RI(I)-1D0 TA(I)=T/TI(I)-1D0 DLK(I)=DL(I)**2 DLL(I)=1D0 TA2(I)=TA(I)**2 10 CONTINUE DLK(4)=DLK(4)**2 DLL(2)=DL(2)**2 DARDRR=0D0 DO 30 I=1,4 ALPHA=AL(I) BETA=BE(I) DLI=DL(I) DLKI=DLK(I) TII=TI(I) CKARD=ALPHA/RI(I)*DLKI*K(I) EX=G(I)*DLL(I)*DEXP(-ALPHA*DLKI-BETA*TA2(I)) DARDRR=DARDRR+EX*CKARD/DLI**2*((K(I)-1)/RI(I)-CKARD) 30 CONTINUE GGG38=G(2)*DL(2)*DEXP(-AL(2)*DLK(2)-BE(2)*TA2(2))/RI(2) CKARD=AL(2)/RI(2)*DLK(2)*K(2) G55D04=2D0*GGG38/DL(2)*(1D0/RI(2)-2D0*CKARD)-DARDRR RETURN END C G56 *** DARDRT OF HELMHOLTZ FUNCTION (RESIDUAL 2) C *** AT T & RO FUNCTION G56D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION K(4),RI(4),TI(4),AL(4),BE(4),G(4) DIMENSION DL(4),DLK(4),DLL(4),TA(4),TA2(4) DATA K/2,2,2,4/,RI/3*0.319D0,1.55D0/ DATA TI/2*640.D0,641.6D0,270D0/ DATA AL/34D0,40D0,30D0,1.050D3/,BE/2*2D4,4D4,2.5D1/ DATA G/-.225D0,-1.68D0,5.5D-2,-93.0D0/ DO 10 I=1,4 DL(I)=RO/RI(I)-1D0 TA(I)=T/TI(I)-1D0 DLK(I)=DL(I)**2 DLL(I)=1D0 TA2(I)=TA(I)**2 10 CONTINUE DLK(4)=DLK(4)**2 DLL(2)=DL(2)**2 DARDRT=0D0 DO 30 I=1,4 ALPHA=AL(I) BETA=BE(I) DLI=DL(I) DLKI=DLK(I) TII=TI(I) CBTRT=BETA*TA(I)/TII CKARD=ALPHA/RI(I)*DLKI*K(I) EX=G(I)*DLL(I)*DEXP(-ALPHA*DLKI-BETA*TA2(I)) DARDRT=DARDRT+EX*CKARD/DLI*CBTRT 30 CONTINUE GGG38=G(2)*DL(2)*DEXP(-AL(2)*DLK(2)-BE(2)*TA2(2))/RI(2) CBTRT=BE(2)*TA(2)/TI(2) CKARD=AL(2)/RI(2)*DLK(2)*K(2) G56D04=2D0*DARDRT-4D0*GGG38*CBTRT RETURN END C G57 *** HELMHOLTZ FUNCTION (IDEAL) AT T FUNCTION G57D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION C(18) DATA C/ 1.97302710180D1,2.09662681977D1,-0.483429455355D0, 1 6.05743189245D0, 2.256023885D1, -9.875324420D0, 2-4.3135538513D0, 4.581557810D-1, -4.7754901883D-2, 3 4.1238460633D-3, -2.7929052852D-4, 1.4481695261D-5, 4-5.6473658748D-7, 1.620044600D-8, -3.3038227960D-10, 5 4.51916067368D-12,-3.70734122708D-14, 1.37546068238D-16/ GASCON=8.31441D0/1.80152D1 TR=T/1D2 RTR=1D0/TR RTR2=RTR*RTR RTR4=RTR2*RTR2 TRI=RTR4 AI=0D0 DO 10 I=3,18 TRI=TRI*TR AI=AI+C(I)*TRI 10 CONTINUE AI=AI+1D0+(C(1)*RTR+C(2))*DLOG(TR) G57D04=-GASCON*T*AI RETURN END C G58 *** DERIVATIVE OG HELMHOLTZ FUNCTION (IDEAL) AT T FUNCTION G58D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION C(18) DATA C/ 1.97302710180D1,2.09662681977D1,-0.483429455355D0, 1 6.05743189245D0, 2.256023885D1, -9.875324420D0, 2-4.3135538513D0, 4.581557810D-1, -4.7754901883D-2, 3 4.1238460633D-3, -2.7929052852D-4, 1.4481695261D-5, 4-5.6473658748D-7, 1.620044600D-8, -3.3038227960D-10, 5 4.51916067368D-12,-3.70734122708D-14, 1.37546068238D-16/ GASCON=8.31441D0/1.80152D1 TR=T/1D2 RTR=1D0/TR RTR2=RTR*RTR RTR4=RTR2*RTR2 TRI=RTR4 DAIDT=0D0 DO 10 I=3,18 TRI=TRI*TR DAIDT=DAIDT+C(I)*(I-5)*TRI 10 CONTINUE DAIDT=DAIDT+1D0+C(1)*RTR+C(2)*(1D0+DLOG(TR)) G58D04=-GASCON*DAIDT RETURN END C G59 *** SECOND DERIVATIVE OF HELMHOLTZ FUNCTION (IDEAL) AT T FUNCTION G59D04(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION C(18) DATA C/ 1.97302710180D1,2.09662681977D1,-0.483429455355D0, 1 6.05743189245D0, 2.256023885D1, -9.875324420D0, 2-4.3135538513D0, 4.581557810D-1, -4.7754901883D-2, 3 4.1238460633D-3, -2.7929052852D-4, 1.4481695261D-5, 4-5.6473658748D-7, 1.620044600D-8, -3.3038227960D-10, 5 4.51916067368D-12,-3.70734122708D-14, 1.37546068238D-16/ GASCON=8.31441D0/1.80152D1 TR=T/1D2 RTR=1D0/TR RTR2=RTR*RTR RTR4=RTR2*RTR2 TRI=RTR4 DAIDTT=0D0 DO 10 I=3,18 TRI=TRI*TR DAIDTT=DAIDTT+C(I)*(I-5)*(I-6)*TRI 10 CONTINUE DAIDTT=DAIDTT-C(1)*RTR+C(2) G59D04=-GASCON/T*DAIDTT RETURN END C G60 *** P AT T & RO FUNCTION G60D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PB=G33D04(T,RO) RS1DR=G44D04(T,RO) RS2DR=G54D04(T,RO) G60D04=PB+RO**2*(RS1DR+RS2DR) RETURN END C G61 *** S AT T & RO FUNCTION G61D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SB=G38D04(T,RO) RS1DT=G42D04(T,RO) RS2DT=G52D04(T,RO) DAIDT=G58D04(T) G61D04=SB-(RS1DT+RS2DT+DAIDT) RETURN END C G62 *** U AT T & RO FUNCTION G62D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) AB=G32D04(T,RO) RS1=G41D04(T,RO) RS2=G51D04(T,RO) AI=G57D04(T) SS=G61D04(T,RO) G62D04=(AB+RS1+RS2+AI)+T*SS RETURN END C G63 *** H AT T & RO FUNCTION G63D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PP=G60D04(T,RO) UU=G62D04(T,RO) G63D04=UU+PP/RO RETURN END C G64 *** G AT T & RO FUNCTION G64D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PB=G33D04(T,RO) GB=G40D04(T,RO) RS1=G41D04(T,RO) RS2=G51D04(T,RO) AI=G57D04(T) PP=G60D04(T,RO) G64D04=GB+(PP-PB)/RO+(RS1+RS2+AI) RETURN END C G65 *** DPDR FUNCTION G65D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) RO2=RO*RO PB=G33D04(T,RO) DPBDRO=G34D04(T,RO) RS1DR=G44D04(T,RO) RS2DR=G54D04(T,RO) RS1DRR=G45D04(T,RO) RS2DRR=G55D04(T,RO) PP=PB+RO2*(RS1DR+RS2DR) G65D04=DPBDRO+2D0*(PP-PB)/RO+RO2*(RS1DRR+RS2DRR) RETURN END C G66 *** DPDT FUNCTION G66D04(T,RO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) RO2=RO*RO DPBDT=G35D04(T,RO) RS1DRT=G46D04(T,RO) RS2DRT=G56D04(T,RO) G66D04=DPBDT+RO2*(RS1DRT+RS2DRT) RETURN END C G71 *** INITIAL VALUE OF SATURATION PRESSURE AT TK FUNCTION G71D04(TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A1,A2,A3,A4,A5,A6 & / -7.85823D+00, 1.83991D+00,-11.7811D+00, & 22.6705D+00, -15.9393D+00, 1.77516D+00/ DATA TC,PC/647.14D+00,22.064D+00/ TH=TK/TC T=1.0D+00-TH TSQ=DSQRT(T) T2=T*T T3=T2*T T5=T3*T2 AA=(A1+A2*TSQ)*T+(A3+A4*TSQ)*T3+(A5+A6*T3*TSQ)*T2*T2 G71D04=PC*DEXP(TC/TK*AA) RETURN END C G72 *** INITIAL VALUE OF ROL AT TK FUNCTION G72D04(TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA B1,B2,B3,B4,B5,B6 & / 1.99206D+00, 1.10123D+00, -5.12506D-01, & -1.75263D+00, -45.4485D+00, -6.75615D+05/ DATA TC,RC/647.14D+00,332D-03/ TH=TK/TC T=1.0D+00-TH EX=1.0D+00/3.0D+00 TR=T**EX TR2=TR*TR T2=T*T T3=T2*T T5=T3*T2 T10=T5*T5 BB=1.0D+00+(B1+B2*TR)*TR+(B3+B4*T3*TR2)*T*TR2 BB=BB+(B5+B6*T10*T10*T2*TR)*T10*T2*T2*TR G72D04=RC*BB RETURN END C G73 *** INITIAL VALUE OF ROG AT TK FUNCTION G73D04(TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA C1,C2,C3,C4,C5,C6 & / -2.02957D+00, -2.68781D+00, -5.38107D+00, & -17.3151D+00, -44.6384D+00, -64.3486D+00/ DATA TC,RC/647.14D+00,322D-03/ TH=TK/TC T=1.0D+00-TH EX=1.0D+00/3.0D+00 TR=T**EX TR2=TR*TR T2=T*T T3=T2*T T5=T3*T2 CC=(C1+C2*TR)*TR+(C3+C4*T*TR2)*T*TR CC=CC+(C5+C6*T5*TR2)*T3*T3*DSQRT(TR) G73D04=RC*DEXP(CC) RETURN END C G74 *** DPS/DT FOR INITIAL VALUE PS AT TK FUNCTION G74D04(TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA A1,A2,A3,A4,A5,A6 & / -7.85823D+00, 1.83991D+00,-11.7811D+00, & 22.6705D+00, -15.9393D+00, 1.77516D+00/ DATA TC,PC/647.14D+00,22.064D+00/ TH=TK/TC T=1.0D+00-TH TSQ=DSQRT(T) T2=T*T T3=T2*T T5=T3*T2 AA1=(A1+A2*TSQ)*T+(A3+A4*TSQ)*T3+(A5+A6*T3*TSQ)*T2*T2 PS=PC*DEXP(TC/TK*AA1) AA2=A1+1.5D+00*A2*TSQ+3*A3*T2+3.5D+00*A4*T2*TSQ AA2=AA2+4*A5*T3+7.5D+00*A6*T5*T*TSQ AAA=-1.0D+00*(TC/TK*AA1+AA2)/TK G74D04=PS*AAA RETURN END C G75 *** INITIAL VALUE OF TSK AT P FUNCTION G75D04(P) IMPLICIT DOUBLE PRECISION (A-H,O-Z) TA=273.16D+00 TB=647.14D+00 PA=G71D04(TA) PB=G71D04(TB) DPA=P-PA DPB=P-PB 10 T=TB+(TA-TB)*0.5D+00 PC=G71D04(T) DPC=P-PC IF (DPA*DPC.LE.0.0 .AND. DPB*DPC.GT.0.0) THEN TB=T PB=PC DPB=DPC ELSEIF (DPA*DPC.GT.0.0 .AND. DPB*DPC.LE.0.0) THEN TA=T PA=PC DPA=DPC ENDIF IF (DABS(DPC)/P .GT. 1.0D-02) GOTO 10 20 P1=G71D04(T) DP=P-P1 IF(DABS(DP/P1).LT.1.0D-07) THEN G75D04=T ELSE DPSDT=G74D04(T) DT=DP/DPSDT T=T+DT GOTO 20 ENDIF RETURN END C S08 *** SATURATION PROPERTIES P RO AT T SUBROUTINE S8D04(T,P,ROG,ROL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA SCEPS/0.325D+00/ IF (T.GE.646.626D0) THEN DT=DABS(1.0D+00-T/647.126D+00) IF (DT.LE.5.0D-07) THEN ROG=0.322D0 ROL=0.322D0 P=22.055D0 ELSE DRO=0.657D0*(DT**SCEPS) ROG=0.322D0-DRO ROL=0.322D0+DRO P=G60D04(T,ROG) ENDIF ELSE P=G71D04(T) RGS=G73D04(T) RLS=G72D04(T) 10 ROG=G2D04(P,T,RGS) ROL=G2D04(P,T,RLS) GG=G64D04(T,ROG) GL=G64D04(T,ROL) PP=ROG*ROL/(ROL-ROG)*((GL-P/ROL)-(GG-P/ROG)) IF(DABS((PP-P)/P).GT.1D-7) THEN P=PP RGS=ROG RLS=ROL GOTO 10 ENDIF ENDIF RETURN END C S09 *** SATURATION PROPERTIES T RO AT P SUBROUTINE S9D04(P,T,ROG,ROL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DP=DABS(P/22.055D0-1.0D+00) IF (DP.LT.1.0D-06) THEN T=647.126D0 ROG=0.322D0 ROL=0.322D0 ELSEIF (P.GT.21.924D+00) THEN ILOOP=0 TA=647.126D+00 TB=646.6259D+00 CALL S8D04(TA,PA,RAG,RAL) CALL S8D04(TB,PB,RBG,RBL) DPA=P-PA DPB=P-PB 20 T=TB+(TA-TB)*0.5D+00 CALL S8D04(T,PC,ROG,ROL) DPC=P-PC IF (DPA*DPC.LE.0.0 .AND. DPB*DPC.GT.0.0) THEN TB=T DPB=DPC ELSEIF (DPA*DPC.GT.0.0 .AND. DPB*DPC.LE.0.0) THEN TA=T DPA=DPC ENDIF ILOOP=ILOOP+1 IF (ILOOP.EQ.10000) THEN RETURN ELSEIF (DABS((TA-TB)/T).GT.1.0D-07) THEN GOTO 20 ENDIF ELSE ILOOP=0 T=G75D04(P) RGC=G73D04(T) RLC=G72D04(T) 10 ROG=G2D04(P,T,RGC) ROL=G2D04(P,T,RLC) SG=G61D04(T,ROG) SL=G61D04(T,ROL) GG=G64D04(T,ROG) GL=G64D04(T,ROL) PP=ROG*ROL/(ROL-ROG)*((GL-P/ROL)-(GG-P/ROG)) DPDT=(SG-SL)/(ROL-ROG)*ROL*ROG DP=P-PP DT=DP/DPDT IF(DABS((DT)/T).GT.1.0D-07) THEN T=T+DT RGC=ROG RLC=ROL GOTO 10 ENDIF ENDIF RETURN END C S10 *** T(P0,H0) R(P0,H0) FROM P(T,R)-P0=0 AND H(T,R)-H0=0 SUBROUTINE S10D04(P,H,T,R,S,U) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (P.LT.6.11731D-4 .OR. P.GT.1.5D3) GOTO 999 PPC=22.055D+00 HHC=2.085776D+03-1.997677535D+03 TCR=647.126D+00 RRC=0.322D+00 DPPC=DABS(P/PPC-1.0D+00) IF (DPPC.LT.1.0D-05) THEN DHHC=DABS(H/HHC-1.0D+00) IF (DHHC.LT.1.0D-05) THEN T=TCR R=RRC S=G61D04(T,R) U=G62D04(T,R) RETURN ENDIF ENDIF IF (P.LE.5D2) THEN TMIN=273.15D0 ELSE TMIN=(P/1D2-5D0)*15+273.15D0 ENDIF TMAX=1273.15D0 RMAX=G1D04(P,TMAX) RMIN=G1D04(P,TMIN) HMAX=G63D04(TMAX,RMAX) HMIN=G63D04(TMIN,RMIN) IF (H.LT.HMIN .OR. H.GT.HMAX) GOTO 999 IF (P.GT.PPC) THEN IF (H.GT.HHC) THEN TA=TMAX RA=RMAX HA=HMAX TB=TCR RB=RRC HB=HHC ELSE TA=TCR RA=RRC HA=HHC TB=TMIN RB=RMIN HB=HMIN ENDIF ELSE CALL S9D04(P,T,RG,RL) HG=G63D04(T,RG) HL=G63D04(T,RL) IF (H.LT.HL) THEN TA=T RA=RL HA=HL TB=TMIN RB=RMIN HB=HMIN ELSEIF (H.LE.HG) THEN VG=1/RG VL=1/RL X=(H-HL)/(HG-HL) V=VL+X*(VG-VL) R=1D0/V SL=G61D04(T,RL) SG=G61D04(T,RG) S=SL+X*(SG-SL) UL=G62D04(T,RL) UG=G62D04(T,RG) 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 RST1=G3D04(RB,RA,P,T) R=G2D04(P,T,RST1) HC=G63D04(T,R) 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=G61D04(T,R) U=G62D04(T,R) ENDIF RETURN 999 T=-1.0E+20 R=-1.0E+20 S=-1.0E+20 U=-1.0E+20 RETURN END C S11 *** T(P0,S0) R(P0,S0) FROM P(T,R)-P0=0 AND S(T,R)-S0=0 SUBROUTINE S11D04(P,S,T,R,H,U) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (P.LT.6.11731D-4 .OR. P.GT.1.5D3) GOTO 999 PPC=22.055D+00 SSC=4.409051D+00+3.515905565D+00 TCR=647.126D+00 RRC=0.322D+00 DPPC=DABS(P/PPC-1.0D+00) IF (DPPC.LT.1.0D-05) THEN DSSC=DABS(S/SSC-1.0D+00) IF (DSSC.LT.1.0D-05) THEN T=TCR R=RRC H=G63D04(T,R) U=G62D04(T,R) RETURN ENDIF ENDIF IF (P.LE.5D2) THEN TMIN=273.15D0 ELSE TMIN=(P/1D2-5D0)*15+273.15D0 ENDIF TMAX=1273.15D0 RMAX=G1D04(P,TMAX) RMIN=G1D04(P,TMIN) SMAX=G61D04(TMAX,RMAX) SMIN=G61D04(TMIN,RMIN) IF (S.LT.SMIN .OR. S.GT.SMAX) GOTO 999 IF (P.GT.PPC) THEN IF (S.GT.SSC) THEN TA=TMAX RA=RMAX SA=SMAX TB=TCR RB=RRC SB=SSC ELSE TA=TCR RA=RRC SA=SSC TB=TMIN RB=RMIN SB=SMIN ENDIF ELSE CALL S9D04(P,T,RG,RL) SG=G61D04(T,RG) SL=G61D04(T,RL) 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=G63D04(T,RG) HL=G63D04(T,RL) H=HL+X*(HG-HL) UG=G62D04(T,RG) UL=G62D04(T,RL) 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 RST1=G3D04(RB,RA,P,T) R=G2D04(P,T,RST1) SC=G61D04(T,R) 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=G63D04(T,R) U=G62D04(T,R) ENDIF RETURN 999 T=-1.0E+20 R=-1.0E+20 H=-1.0E+20 U=-1.0E+20 RETURN END C *** FUNCTION FOR REGION CHECK C G91 FUNC(P) TYPE FUNCTION G91D04(P) DOUBLE PRECISION PCR,PTR,DP,PD INTEGER G91D04 DATA PCR,PTR/220.55D+00,6.11731D-03/ PD=DBLE(P) IF (PD.LT.PTR) THEN G91D04=3 ELSEIF (PD.LT.PCR+0.0001D+00) THEN G91D04=0 ELSE G91D04=3 ENDIF IF (G91D04.EQ.0) THEN DP=1.0D+00-PD/PCR IF (DP.LT.1.0D-06) THEN G91D04=1 ENDIF ENDIF RETURN END C G92 FUNC(T) TYPE FUNCTION G92D04(T) DOUBLE PRECISION TTR,TCR,TKCR,TD,TK,DT INTEGER G92D04 DATA TTR,TCR,TKCR/0.01D+00,373.976D+00,647.126D+00/ TD=DBLE(T) IF (TD.LT.TTR) THEN G92D04=3 ELSEIF (TD.LT.TCR+0.0001D+00) THEN G92D04=0 ELSE G92D04=3 ENDIF IF (G92D04.EQ.0) THEN TK=TD+273.15D+00 DT=1.0E+00-TK/TKCR IF (DT.LT.5.0D-07) THEN G92D04=1 ENDIF ENDIF RETURN END C G93 FUNC(P,T) TYPE FUNCTION G93D04(P,T) INTEGER G93D04 DATA PCR,TKCR,PTR/220.55,647.126E+00,6.11731E-3/ DP=ABS(1.0E+00-P/PCR) IF (DP.LE.1.0E-05) THEN DT=ABS(1.0E+00-(T+273.15E+00)/TKCR) IF(DT.LE.1.0E-05) THEN G93D04=1 RETURN ENDIF ENDIF IF (P.GE.PTR) THEN IF (T.GE.0) THEN IF (T.LE.1000) THEN IF (T.LT.150) THEN PMAX=1.0E+03*(5E0+T/15E0) ELSE PMAX=1.5E4 ENDIF IF (P.LE.PMAX) THEN G93D04=2 RETURN ENDIF ENDIF ENDIF ENDIF G93D04=3 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