C ************************************* C * PROPATH FOR D2O * C * * C * VERSION 6.1 * C * CODED (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 * MARCH 1989 * C ************************************* C * SUPERVISOR FOR D2O * C * CODED (MAR. 1989) VER.1.1 * C * REVISED (MAR. 1990) VER.1.2 * C * REVISED (AUG. 1991) VER.2.1 * 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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(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 S99D07(FUN) WTDD=-1.0E+30 RETURN END C C==================================================================== C------------------------------------------------- F1 = AIPPT REAL FUNCTION AIPPT(P,T) CHARACTER FUN*6 DATA FUN/'AIPPT'/ CALL S99D07(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=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL - FF = F94D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - AJTPT=FF RETURN END C------------------------------------------------- F82 = AKPT REAL FUNCTION AKPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'AKPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F82D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AKPT=FF RETURN END C------------------------------------------------- F2 = ALAPP REAL FUNCTION ALAPP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALAPP'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F2D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALAPP=FF RETURN END C------------------------------------------------- F3 = ALAPT REAL FUNCTION ALAPT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALAPT'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F3D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALAPT=FF RETURN END C------------------------------------------------- F4 = ALHP REAL FUNCTION ALHP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALHP'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F4D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALHP=FF RETURN END C------------------------------------------------- F5 = ALHT REAL FUNCTION ALHT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALHT'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F5D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALHT=FF RETURN END C------------------------------------------------- F6 = ALMPD REAL FUNCTION ALMPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALMPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F6D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMPD=FF RETURN END C------------------------------------------------- F7 = ALMPDD REAL FUNCTION ALMPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'ALMPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F7D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMPDD=FF RETURN END C------------------------------------------------- F8 = ALMPT REAL FUNCTION ALMPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'ALMPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F8D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMPT=FF RETURN END C------------------------------------------------- F9 = ALMTD REAL FUNCTION ALMTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALMTD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F9D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMTD=FF RETURN END C------------------------------------------------- F10 = ALMTDD REAL FUNCTION ALMTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'ALMTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F10D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- ALMTDD=FF RETURN END C------------------------------------------------- F11 = AMUPD REAL FUNCTION AMUPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'AMUPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F11D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUPD=FF RETURN END C------------------------------------------------- F12 = AMUPDD REAL FUNCTION AMUPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'AMUPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F12D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUPDD=FF RETURN END C------------------------------------------------- F13 = AMUPT REAL FUNCTION AMUPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'AMUPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F13D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUPT=FF RETURN END C------------------------------------------------- F14 = AMUTD REAL FUNCTION AMUTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'AMUTD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F14D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- AMUTD=FF RETURN END C------------------------------------------------- F15 = AMUTDD REAL FUNCTION AMUTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'AMUTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F15D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL - FF = F90D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL - FF = F91D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL - FF = F92D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL - FF = F93D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - BVPT=FF RETURN END C------------------------------------------------- F16 = CPPD REAL FUNCTION CPPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CPPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F16D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPPD=FF RETURN END C------------------------------------------------- F17 = CPPDD REAL FUNCTION CPPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CPPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F17D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPPDD=FF RETURN END C------------------------------------------------- F18 = CPPT REAL FUNCTION CPPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'CPPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F18D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPPT=FF RETURN END C------------------------------------------------- F19 = CPTD REAL FUNCTION CPTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'CPTD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F19D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPTD=FF RETURN END C------------------------------------------------- F20 = CPTDD REAL FUNCTION CPTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'CPTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F20D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CPTDD=FF RETURN END C------------------------------------------------- F21 = CRP REAL FUNCTION CRP(A) CHARACTER FUN*6,A*1 REAL T0K,PBAR,FF C--- FUNCTION NAME -- DATA FUN/'CRP'/ C--- SET OF UNIT -- C--- FUNCTION CALL -- FF = F21D07(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 ', & ' HEAVY WATER WHEN A=',A,' ****') CRP=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- IF(A.EQ.'T') THEN T0K=-G99D07(0.0) FF=FF+T0K ELSE IF(A.EQ.'P') THEN PBAR=G98D07(1.0) FF=FF/PBAR END IF CRP=FF RETURN END C------------------------------------------------- F76 = CVPDD REAL FUNCTION CVPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'CVPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F76D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CVPDD=FF RETURN END C------------------------------------------------- F77 = CVPT REAL FUNCTION CVPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'CVPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F77D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CVPT=FF RETURN END C------------------------------------------------- F78 = CVTDD REAL FUNCTION CVTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'CVTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F78D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- CVTDD=FF RETURN END C------------------------------------------------- F22 = EPSPT REAL FUNCTION EPSPT(P,T) CHARACTER FUN*6 DATA FUN/'EPSPT'/ CALL S99D07(FUN) EPSPT=-1.0E+30 RETURN END C------------------------------------------------- F89 = FC C************************************************ C FUNCTION FOR FUNDDAMENTAL CONSTANTS C PROPATH VER.7.1, MAY 8, 1990 C USAGE: B=FC(A) C A, B : CHARACTER TYPE VALIABLES C B='20.027' WHEN A='M' C B='415.15' WHEN A='R' C************************************************ REAL FUNCTION FC(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'M') THEN FC=20.027 ELSE IF (A.EQ.'R') THEN FC=415.15 ELSE FC=-1.E+20 IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT FC FOR HEAVY WATER 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=G98D07(P) C--- FUNCTION CALL - FF = F96D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL - FF = F95D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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=G99D07(T) C--- FUNCTION CALL - FF = F97D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION - GAMTDD=FF RETURN END C------------------------------------------------- F23 = HPD REAL FUNCTION HPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'HPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F23D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPD=FF RETURN END C------------------------------------------------- F24 = HPDD REAL FUNCTION HPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'HPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F24D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPDD=FF RETURN END C------------------------------------------------- F71 = HPS REAL FUNCTION HPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'HPS'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F71D07(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPS=FF RETURN END C------------------------------------------------- F25 = HPT REAL FUNCTION HPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'HPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F25D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPT=FF RETURN END C------------------------------------------------- F26 = HPX REAL FUNCTION HPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'HPX'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F26D07(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HPX=FF RETURN END C------------------------------------------------- F27 = HTD REAL FUNCTION HTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F27D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HTD=FF RETURN END C------------------------------------------------- F28 = HTDD REAL FUNCTION HTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F28D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- HTDD=FF RETURN END C------------------------------------------------- F29 = HTX REAL FUNCTION HTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'HTX'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F29D07(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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='HEAVY WATER' WHEN A='S' C B='D2O' 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='HEAVY WATER' ELSE IF (A.EQ.'C') THEN IDENTF='D2O' ELSE IF (A.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT IDENTF FOR HEAVY WATER WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F66 = PLDT REAL FUNCTION PLDT(T) CHARACTER FUN*6 DATA FUN/'PLDT'/ CALL S99D07(FUN) PLDT=-1.0E+30 RETURN END C------------------------------------------------- F68 = PMLT REAL FUNCTION PMLT(T) CHARACTER FUN*6 DATA FUN/'PMLT'/ CALL S99D07(FUN) PMLT=-1.0E+30 RETURN END C------------------------------------------------- F85 = PRPD REAL FUNCTION PRPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'PRPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F85D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRPD=FF RETURN END C------------------------------------------------- F86 = PRPDD REAL FUNCTION PRPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'PRPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F86D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRPDD=FF RETURN END C------------------------------------------------- F81 = PRPT REAL FUNCTION PRPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'PRPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F81D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRPT=FF RETURN END C------------------------------------------------- F87 = PRTD REAL FUNCTION PRTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'PRTD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F87D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRTD=FF RETURN END C------------------------------------------------- F88 = PRTDD REAL FUNCTION PRTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'PRTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F88D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- PRTDD=FF RETURN END C------------------------------------------------- F99 = PSBT REAL FUNCTION PSBT(T) CHARACTER FUN*6 DATA FUN/'PSBT'/ CALL S99D07(FUN) PSBT=-1.0E+30 RETURN END C------------------------------------------------- F30 = PST REAL FUNCTION PST(T) CHARACTER FUN*6 REAL PBAR,T,FF C--- FUNCTION NAME -- DATA FUN/'PST'/ C--- SET OF UNIT -- PBAR=G98D07(1.0) TI=G99D07(T) C--- FUNCTION CALL -- FF = F30D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) PST=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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 REAL FUNCTION PSTD(T) CHARACTER FUN*6 DATA FUN/'PSTD'/ CALL S99D07(FUN) PSTD=-1.0E+30 RETURN END C------------------------------------------------- F73 = PSTDD REAL FUNCTION PSTDD(T) CHARACTER FUN*6 DATA FUN/'PSTDD'/ CALL S99D07(FUN) PSTDD=-1.0E+30 RETURN END C------------------------------------------------- F31 = SIGP REAL FUNCTION SIGP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SIGP'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F31D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSEIF (FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SIGP=FF RETURN END C------------------------------------------------- F32 = SIGT REAL FUNCTION SIGT(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'SIGT'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F32D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF (FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSEIF (FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SIGT=FF RETURN END C------------------------------------------------- F33 = SPD REAL FUNCTION SPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F33D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPD=FF RETURN END C------------------------------------------------- F34 = SPDD REAL FUNCTION SPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'SPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F34D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPDD=FF RETURN END C------------------------------------------------- F35 = SPT REAL FUNCTION SPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'SPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F35D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPT=FF RETURN END C------------------------------------------------- F36 = SPX REAL FUNCTION SPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'SPX'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F36D07(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- SPX=FF RETURN END C------------------------------------------------- F37 = STD REAL FUNCTION STD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F37D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- STD=FF RETURN END C------------------------------------------------- F38 = STDD REAL FUNCTION STDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F38D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- STDD=FF RETURN END C------------------------------------------------- F39 = STX REAL FUNCTION STX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'STX'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F39D07(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- STX=FF RETURN END C------------------------------------------------- F67 = TLDP REAL FUNCTION TLDP(P) CHARACTER FUN*6 DATA FUN/'TLDP'/ CALL S99D07(FUN) TLDP=-1.0E+30 RETURN END C------------------------------------------------- F69 = TMLP REAL FUNCTION TMLP(P) CHARACTER FUN*6 DATA FUN/'TMLP'/ CALL S99D07(FUN) TMLP=-1.0E+30 RETURN END C------------------------------------------------- F64 = TPH REAL FUNCTION TPH(P,H) CHARACTER FUN*6 REAL T0K,P,H,FF C--- FUNCTION NAME -- DATA FUN/'TPH'/ C--- SET OF UNIT -- PI=G98D07(P) T0K=-G99D07(0.0) C--- FUNCTION CALL -- FF = F64D07(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) TPH=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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 REAL FUNCTION TPSEUP(P) CHARACTER FUN*6 REAL P,FF DATA FUN/'TPSEUP'/ C--- SET OF UNIT -- PI=G98D07(P) T0K=-G99D07(0.0) C--- FUNCTION CALL -- FF = F98D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) TPSEUP=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) TPSEUP=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- TPSEUP=FF+T0K RETURN END C------------------------------------------------- F65 = TPS REAL FUNCTION TPS(P,S) CHARACTER FUN*6 REAL T0K,P,S,FF C--- FUNCTION NAME -- DATA FUN/'TPS'/ C--- SET OF UNIT -- PI=G98D07(P) T0K=-G99D07(T) C--- FUNCTION CALL -- FF = F65D07(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) TPS=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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 REAL FUNCTION TPV(P,V) CHARACTER FUN*6 REAL T0K,P,V,FF C--- FUNCTION NAME -- DATA FUN/'TPV'/ C--- SET OF UNIT -- PI=G98D07(P) T0K=-G99D07(0.0) C--- FUNCTION CALL -- FF = F70D07(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) TPV=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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 REAL 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 = F41D07(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 ', & ' HEAVY WATER WHEN A=',A,' ****') TRPL=-1.0E+20 RETURN END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- IF(A.EQ.'T') THEN T0K=-G99D07(0.0) FF=FF+T0K ELSE IF(A.EQ.'P') THEN PBAR=G98D07(1.0) FF=FF/PBAR END IF TRPL=FF RETURN END C------------------------------------------------- F100 = TSBP REAL FUNCTION TSBP(P) CHARACTER FUN*6 DATA FUN/'TSBP'/ CALL S99D07(FUN) TSBP=-1.0E+30 RETURN END C------------------------------------------------- F40 = TSP REAL FUNCTION TSP(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'TSP'/ C--- SET OF UNIT -- PI=G98D07(P) T0K=-G99D07(0.0) C--- FUNCTION CALL -- FF = F40D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) TSP=-1.0E+10 RETURN C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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 REAL FUNCTION TSPD(P) CHARACTER FUN*6 DATA FUN/'TSPD'/ CALL S99D07(FUN) TSPD=-1.0E+30 RETURN END C------------------------------------------------- F75 = TSPDD REAL FUNCTION TSPDD(P) CHARACTER FUN*6 DATA FUN/'TSPDD'/ CALL S99D07(FUN) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F42 = UPD REAL FUNCTION UPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'UPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F42D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPD=FF RETURN END C------------------------------------------------- F43 = UPDD REAL FUNCTION UPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'UPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F43D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPDD=FF RETURN END C------------------------------------------------- F79 = UPS REAL FUNCTION UPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'UPS'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F79D07(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPS=FF RETURN END C------------------------------------------------- F44 = UPT REAL FUNCTION UPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'UPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F44D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPT=FF RETURN END C------------------------------------------------- F45 = UPX REAL FUNCTION UPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'UPX'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F45D07(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UPX=FF RETURN END C------------------------------------------------- F46 = UTD REAL FUNCTION UTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F46D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTD=FF RETURN END C------------------------------------------------- F47 = UTDD REAL FUNCTION UTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F47D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTDD=FF RETURN END C------------------------------------------------- F48 = UTX REAL FUNCTION UTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'UTX'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F48D07(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- UTX=FF RETURN END C------------------------------------------------- F49 = VPD REAL FUNCTION VPD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'VPD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F49D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPD=FF RETURN END C------------------------------------------------- F50 = VPDD REAL FUNCTION VPDD(P) CHARACTER FUN*6 REAL P,FF C--- FUNCTION NAME -- DATA FUN/'VPDD'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F50D07(PI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(1,P,P,'P','P',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPDD=FF RETURN END C------------------------------------------------- F80 = VPS REAL FUNCTION VPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'VPS'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F80D07(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPS=FF RETURN END C------------------------------------------------- F51 = VPT REAL FUNCTION VPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'VPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F51D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPT=FF RETURN END C------------------------------------------------- F52 = VPX REAL FUNCTION VPX(P,X) CHARACTER FUN*6 REAL P,X,FF C--- FUNCTION NAME -- DATA FUN/'VPX'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F52D07(PI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,X,'P','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VPX=FF RETURN END C------------------------------------------------- F53 = VTD REAL FUNCTION VTD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F53D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTD=FF RETURN END C------------------------------------------------- F54 = VTDD REAL FUNCTION VTDD(T) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTDD'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F54D07(TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(2,T,T,'T','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTDD=FF RETURN END C------------------------------------------------- F55 = VTX REAL FUNCTION VTX(T,X) CHARACTER FUN*6 REAL T,FF C--- FUNCTION NAME -- DATA FUN/'VTX'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F55D07(TI,X) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,T,X,'T','X',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- VTX=FF RETURN END C------------------------------------------------- F83 = WPT REAL FUNCTION WPT(P,T) CHARACTER FUN*6 REAL P,T,FF C--- FUNCTION NAME -- DATA FUN/'WPT'/ C--- SET OF UNIT -- PI=G98D07(P) TI=G99D07(T) C--- FUNCTION CALL -- FF = F83D07(PI,TI) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,T,'P','T',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- WPT=FF RETURN END C------------------------------------------------- F56 = XPH REAL FUNCTION XPH(P,H) CHARACTER FUN*6 REAL P,H,FF C--- FUNCTION NAME -- DATA FUN/'XPH'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F56D07(PI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,H,'P','H',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPH=FF RETURN END C------------------------------------------------- F57 = XPS REAL FUNCTION XPS(P,S) CHARACTER FUN*6 REAL P,S,FF C--- FUNCTION NAME -- DATA FUN/'XPS'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F57D07(PI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,S,'P','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPS=FF RETURN END C------------------------------------------------- F58 = XPU REAL FUNCTION XPU(P,U) CHARACTER FUN*6 REAL P,U,FF C--- FUNCTION NAME -- DATA FUN/'XPU'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F58D07(PI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,U,'P','U',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPU=FF RETURN END C------------------------------------------------- F59 = XPV REAL FUNCTION XPV(P,V) CHARACTER FUN*6 REAL P,V,FF C--- FUNCTION NAME -- DATA FUN/'XPV'/ C--- SET OF UNIT -- PI=G98D07(P) C--- FUNCTION CALL -- FF = F59D07(PI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,P,V,'P','V',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XPV=FF RETURN END C------------------------------------------------- F60 = XTH REAL FUNCTION XTH(T,H) CHARACTER FUN*6 REAL T,H,FF C--- FUNCTION NAME -- DATA FUN/'XTH'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F60D07(TI,H) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,T,H,'T','H',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTH=FF RETURN END C------------------------------------------------- F61 = XTS REAL FUNCTION XTS(T,S) CHARACTER FUN*6 REAL T,S,FF C--- FUNCTION NAME -- DATA FUN/'XTS'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F61D07(TI,S) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,T,S,'T','S',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTS=FF RETURN END C------------------------------------------------- F62 = XTU REAL FUNCTION XTU(T,U) CHARACTER FUN*6 REAL T,U,FF C--- FUNCTION NAME -- DATA FUN/'XTU'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F62D07(TI,U) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(3,T,U,'T','U',FUN) END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION -- XTU=FF RETURN END C------------------------------------------------- F63 = XTV REAL FUNCTION XTV(T,V) CHARACTER FUN*6 REAL T,V,FF C--- FUNCTION NAME -- DATA FUN/'XTV'/ C--- SET OF UNIT -- TI=G99D07(T) C--- FUNCTION CALL -- FF = F63D07(TI,V) C--- LEVEL 1 ERROR CHECK & MESSAGE -- IF(FF.EQ.-1.0E+10) THEN CALL S97D07(FUN) C--- LEVEL 2 ERROR CHECK & MESSAGE -- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98D07(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 (P) **** FUNCTION G98D07(P) REAL P,G98D07 DOUBLE PRECISION PBAR INTEGER KPA,MESS COMMON/UNIT/KPA,MESS IF(KPA.EQ.1) THEN PBAR=1.0D+00 ELSEIF (KPA.EQ.2) THEN PBAR=1.0D+00 ELSEIF (KPA.EQ.3) THEN PBAR=1.0D-05 ELSE PBAR=1.0D-05 END IF G98D07=REAL(DBLE(P)*PBAR) RETURN END C------------------------------------------------- G99 C *** FUNCTION FOR SETTING UNITS (T) **** FUNCTION G99D07(T) REAL T,G99D07 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 G99D07=REAL(DBLE(T)-T0K) RETURN END C------------------------------------------------- S97 C *** LEVEL 1 ERROR MESSAGE -- SUBROUTINE S97D07(FUN) CHARACTER FLUID*11,FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA FLUID/'HEAVY WATER'/ IF (MESS.NE.0) THEN WRITE(6,1000) FUN,FLUID 1000 FORMAT(1H ,5X,'**** NO CONVERGENCE AT ',A6,' FOR ', & A11,' ****') ENDIF RETURN END C------------------------------------------------- S98 C *** LEVEL 2 ERROR MESSAGE -- SUBROUTINE S98D07(IPT,P,T,N1,N2,FUN) CHARACTER FLUID*11,FUN*6,N1*1,N2*1 REAL P,T INTEGER KPA,MESS,IPT COMMON/UNIT/KPA,MESS DATA FLUID/'HEAVY WATER'/ 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 ',A11, & ' 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 ',A11, & ' 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 ',A11, & ' WHEN ',A1,'=',1PE14.7,' AND ',A1,'=',1PE14.7,' ****') ENDIF ENDIF RETURN END C------------------------------------------------- S99 C *** LEVEL 3 ERROR MESSAGE -- SUBROUTINE S99D07(FUN) CHARACTER FLUID*11,FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA FLUID/'HEAVY WATER'/ IF (MESS.NE.0) THEN WRITE(6,1000) FUN,FLUID 1000 FORMAT(1H ,5X,'**** FUNCTION ',A6,' UNAVAILABLE FOR ', & A11,' ****') ENDIF RETURN END C ****************************************** C * FUNCTION PROGRAMS OF HEAVY WATER * C * * C * CODED (MAR. 1989) VER.1.1 * C * BY * C * TAMAMI FUJINO * C * * C * REVISED (MAR. 1990) VER.1.2 * C * REVISED (AUG. 1991) VER.2.1 * C * BY * C * TOMOHIRO HONDA * C * FUKUOKA UNIVERSITY * C * FUKUOKA, 814-01, JAPAN * C * MARCH, 1989 * C ****************************************** C F02 + LAPLACE COEFFICIENT AT P FUNCTION F2D07(P) DOUBLE PRECISION G13D07,YP,TK INTEGER G91D07 IG91=G91D07(P) IF (IG91.EQ.0) THEN YP=DBLE(P*0.1) TK=G13D07(YP) F2D07=G17D07(TK) ELSEIF (IG91.EQ.1) THEN F2D07=0.0 ELSE F2D07=-1.0E+20 ENDIF RETURN END C F03 + LAPLACE COEFFICIENT AT T FUNCTION F3D07(T) DOUBLE PRECISION TK INTEGER G92D07 IG92=G92D07(T) IF (IG92.EQ.0) THEN TK=DBLE(T+273.15) F3D07=G17D07(TK) ELSEIF (IG92.EQ.1) THEN F3D07=0.0 ELSE F3D07=-1.0E+20 ENDIF RETURN END C F04 + LATENT HEAT OF VAPORIZATION AT P FUNCTION F4D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F4D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) F4D07=REAL(G5D07(YT))*1E3 ENDIF RETURN END C F05 + LATENT HEAT OF VAPORIZATION AT T FUNCTION F5D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F5D07=-1.0E+20 ELSE YT=DBLE(T+273.15) F5D07=REAL(G5D07(YT))*1E3 ENDIF RETURN END C F06 + LUMDA OF SATURATED LIQUID AT P FUNCTION F6D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT)*1D3 F6D07=REAL(G51D07(YRL,YT)) ELSE F6D07=-1.0E+20 ENDIF RETURN END C F07 + LUMDA OF SATURATED VAPOR AT P FUNCTION F7D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT)*1D3 F7D07=REAL(G51D07(YRG,YT)) ELSE F7D07=-1.0E+20 ENDIF RETURN END C F08 + LUMDA AT P AND T FUNCTION F8D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.550.) GOTO 999 YP=DBLE(P*0.1) YT=DBLE(T+273.15) YR=G7D07(YP,YT)*1D3 F8D07=REAL(G51D07(YR,YT)) RETURN 999 F8D07=-1.0E+20 RETURN END C F09 + LUMDA OF SATURATED LIQUID AT T FUNCTION F9D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN YT=DBLE(T+273.15) YRL=G16D07(YT)*1D3 F9D07=REAL(G51D07(YRL,YT)) ELSE F9D07=-1.0E+20 ENDIF RETURN END C F10 + LUMDA OF SATURATED VAPOR AT T FUNCTION F10D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN YT=DBLE(T+273.15) YRG=G15D07(YT)*1D3 F10D07=REAL(G51D07(YRG,YT)) ELSE F10D07=-1.0E+20 ENDIF RETURN END C F11 + MYU OF SATURATED LIQUID AT P FUNCTION F11D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F11D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT)*1D3 F11D07=REAL(G50D07(YRL,YT)) ENDIF RETURN END C F12 + MYU OF SATURATED VAPOR AT P FUNCTION F12D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F12D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT)*1D3 F12D07=REAL(G50D07(YRG,YT)) ENDIF RETURN END C F13 + MYU AT P AND T FUNCTION F13D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.500.) GOTO 999 YP=DBLE(P*0.1) YT=DBLE(T+273.15) YR=G7D07(YP,YT)*1D3 F13D07=REAL(G50D07(YR,YT)) RETURN 999 F13D07=-1.0E+20 RETURN END C F14 + MYU OF SATURATED LIQUID AT T FUNCTION F14D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F14D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRL=G16D07(YT)*1D3 F14D07=REAL(G50D07(YRL,YT)) ENDIF RETURN END C F15 + MYU OF SATURATED VAPOR AT T FUNCTION F15D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F15D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT)*1D3 F15D07=REAL(G50D07(YRG,YT)) ENDIF RETURN END C F16 + CP OF SATURATED LIQUID AT P FUNCTION F16D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT) YCP=G8D07(YRL,YT) IF (YCP.LT.-1.0E+08) THEN F16D07=-1.0E+20 ELSE F16D07=REAL(YCP)*1E3 ENDIF ELSE F16D07=-1.0E+20 ENDIF RETURN END C F17 + CP OF SATURATED VAPOUR AT P FUNCTION F17D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) YCP=G8D07(YRG,YT) IF (YCP.LT.-1.0E+08) THEN F17D07=-1.0E+20 ELSE F17D07=REAL(YCP)*1E3 ENDIF ELSE F17D07=-1.0E+20 ENDIF RETURN END C F18 + CP AT P AND T FUNCTION F18D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D07 IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 IF (G93D07(P,T).EQ.2) THEN YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) YCP=G8D07(YR,YT) IF (YCP.LT.-1.0E+08) THEN F18D07=-1.0E+20 ELSE F18D07=REAL(YCP)*1E3 ENDIF ELSE F18D07=-1.0E+20 ENDIF RETURN 999 F18D07=-1.0E+20 RETURN END C F19 + CP OF SATURATED LIQUID AT T FUNCTION F19D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN YT=DBLE(T+273.15) YRL=G16D07(YT) YCP=G8D07(YRL,YT) IF (YCP.LT.-1.0E+08) THEN F19D07=-1.0E+20 ELSE F19D07=REAL(YCP)*1E3 ENDIF ELSE F19D07=-1.0E+20 ENDIF RETURN END C F20 + CP OF SATURATED VAPOUR AT T FUNCTION F20D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN YT=DBLE(T+273.15) YRG=G15D07(YT) YCP=G8D07(YRG,YT) IF (YCP.LT.-1.0E+08) THEN F20D07=YCP ELSE F20D07=REAL(YCP)*1E3 ENDIF ELSE F20D07=-1.0E+20 ENDIF RETURN END C F21 + CRITICAL POINT FUNCTION F21D07(A) CHARACTER*1 A IF (A.EQ.'H') THEN F21D07=1965.7E3 ELSEIF (A.EQ.'P') THEN F21D07=216.6 ELSEIF (A.EQ.'S') THEN F21D07=4.1815E3 ELSEIF (A.EQ.'T') THEN F21D07=370.74 ELSEIF (A.EQ.'V') THEN F21D07=1E0/358 ELSE F21D07=-1.0E+20 ENDIF RETURN END C F23 + H OF SATURATED LIQUID AT P FUNCTION F23D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F23D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT) F23D07=REAL(G4D07(YRL,YT))*1E3+1.417202E+01 ENDIF RETURN END C F24 + H OF SATURATED VAPOUR AT P FUNCTION F24D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F24D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) F24D07=REAL(G4D07(YRG,YT))*1E3+1.417202E+01 ENDIF RETURN END C F25 + H AT P AND T FUNCTION F25D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YP=DBLE(P*0.1) YT=DBLE(T+273.15) YR=G7D07(YP,YT) F25D07=REAL(G4D07(YR,YT))*1E3+1.417202E+01 RETURN 999 F25D07=-1.0E+20 RETURN END C F26 + H OF MIXTURE AT P FUNCTION F26D07(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F26D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F26D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) YRL=G16D07(YT) HG=REAL(G4D07(YRG,YT)) HL=REAL(G4D07(YRL,YT)) F26D07=(HL+X*(HG-HL))*1E3+1.417202E+01 ENDIF RETURN END C F27 + H OF SATURATED LIQUID AT T FUNCTION F27D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F27D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRL=G16D07(YT) F27D07=REAL(G4D07(YRL,YT))*1E3+1.417202E+01 ENDIF RETURN END C F28 + H OF SATURATED VAPOUR AT T FUNCTION F28D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F28D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) F28D07=REAL(G4D07(YRG,YT))*1E3+1.417202E+01 ENDIF RETURN END C F29 + H OF MIXTURE AT T FUNCTION F29D07(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F29D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F29D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) YRL=G16D07(YT) HG=REAL(G4D07(YRG,YT)) HL=REAL(G4D07(YRL,YT)) F29D07=(HL+X*(HG-HL))*1E3+1.417202E+01 ENDIF RETURN END C F30 + SATURATION PRESSURE AT T FUNCTION F30D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IK=G92D07(T) IF (IK.EQ.3) THEN F30D07=-1.0E+20 ELSEIF (IK.EQ.1) THEN F30D07=216.6E+00 ELSE YT=DBLE(T+273.15) F30D07=REAL(G12D07(YT))*10. ENDIF RETURN END C F31 + SURFACE TENSION AT P FUNCTION F31D07(P) DOUBLE PRECISION G13D07,YP INTEGER G91D07 IK=G91D07(P) IF (IK.EQ.3) THEN F31D07=-1.0E+20 ELSEIF (IK.EQ.1) THEN F31D07=0.0E+00 ELSE YP=DBLE(P*0.1) TK=REAL(G13D07(YP)) F31D07=G11D07(TK) ENDIF RETURN END C F32 + SURFACE TENSION AT T FUNCTION F32D07(T) INTEGER G92D07 IK=G92D07(T) IF (IK.EQ.3) THEN F32D07=-1.0E+20 ELSEIF (IK.EQ.1) THEN F32D07=0.0E+00 ELSE TK=T+273.15E+00 F32D07=G11D07(TK) ENDIF RETURN END C F33 + S OF SATURATED LIQUID AT P FUNCTION F33D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F33D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT) F33D07=REAL(G3D07(YRL,YT))*1E3 ENDIF RETURN END C F34 + S OF SATURATED VAPOUR AT P FUNCTION F34D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F34D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) F34D07=REAL(G3D07(YRG,YT))*1E3 ENDIF RETURN END C F35 + S AT P AND T FUNCTION F35D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YP=DBLE(P*0.1) YT=DBLE(T+273.15) YR=G7D07(YP,YT) F35D07=REAL(G3D07(YR,YT))*1E3 RETURN 999 F35D07=-1.0E+20 RETURN END C F36 + S OF MIXTURE AT P FUNCTION F36D07(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F36D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F36D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) YRL=G16D07(YT) SG=REAL(G3D07(YRG,YT))*1E3 SL=REAL(G3D07(YRL,YT))*1E3 F36D07=SL+X*(SG-SL) ENDIF RETURN END C F37 + S OF SATURATED LIQUID AT T FUNCTION F37D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F37D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRL=G16D07(YT) F37D07=REAL(G3D07(YRL,YT))*1E3 ENDIF RETURN END C F38 + S OF SATURATED VAPOUR AT T FUNCTION F38D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F38D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) F38D07=REAL(G3D07(YRG,YT))*1E3 ENDIF RETURN END C F39 + S OF MIXTURE AT T FUNCTION F39D07(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F39D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F39D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) YRL=G16D07(YT) SG=REAL(G3D07(YRG,YT))*1E3 SL=REAL(G3D07(YRL,YT))*1E3 F39D07=SL+X*(SG-SL) ENDIF RETURN END C F40 + SATURATION TEMPERATURE AT P FUNCTION F40D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IK=G91D07(P) IF (IK.EQ.3) THEN F40D07=-1.0E+20 ELSEIF (IK.EQ.1) THEN F40D07=370.74E+00 ELSE YP=DBLE(P*0.1) F40D07=REAL(G13D07(YP))-273.15 ENDIF RETURN END C F41 + TRIPLE POINT FUNCTION F41D07(A) CHARACTER*1 A IF (A.EQ.'P') THEN F41D07=0.6601E-2 ELSEIF (A.EQ.'T') THEN F41D07=3.8 ELSE F41D07=-1.0E+20 ENDIF RETURN END C F42 + U OF SATURATED LIQUID AT P FUNCTION F42D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F42D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT) F42D07=REAL(G6D07(YRL,YT))*1E3+1.417202E+01 ENDIF RETURN END C F43 + U OF SATURATED VAPOUR AT P FUNCTION F43D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F43D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) F43D07=REAL(G6D07(YRG,YT))*1E3+1.417202E+01 ENDIF RETURN END C F44 + U AT P AND T FUNCTION F44D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YP=DBLE(P*0.1) YT=DBLE(T+273.15) YR=G7D07(YP,YT) F44D07=REAL(G6D07(YR,YT))*1E3+1.417202E+01 RETURN 999 F44D07=-1.0E+20 RETURN END C F45 + U OF MIXTURE AT P FUNCTION F45D07(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F45D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F45D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) YRL=G16D07(YT) UG=REAL(G6D07(YRG,YT)) UL=REAL(G6D07(YRL,YT)) F45D07=(UL+X*(UG-UL))*1E3+1.417202E+01 ENDIF RETURN END C F46 + U OF SATURATED LIQUID AT T FUNCTION F46D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F46D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRL=G16D07(YT) F46D07=REAL(G6D07(YRL,YT))*1E3+1.417202E+01 ENDIF RETURN END C F47 + U OF SATURATED VAPOUR AT T FUNCTION F47D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F47D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) F47D07=REAL(G6D07(YRG,YT))*1E3+1.417202E+01 ENDIF RETURN END C F48 + U OF MIXTURE AT T FUNCTION F48D07(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F48D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F48D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) YRL=G16D07(YT) UG=REAL(G6D07(YRG,YT)) UL=REAL(G6D07(YRL,YT)) F48D07=(UL+X*(UG-UL))*1E3+1.417202E+01 ENDIF RETURN END C F49 + V OF SATURATED LIQUID AT P FUNCTION F49D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F49D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT) F49D07=1E-3/REAL(YRL) ENDIF RETURN END C F50 + V OF SATURATED GAS AT P FUNCTION F50D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F50D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) F50D07=1E-3/REAL(YRG) ENDIF RETURN END C F51 + V AT P AND T FUNCTION F51D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YP=DBLE(P)*1.0D-01 YT=DBLE(T)+273.15D+00 F51D07=1E-3/REAL(G7D07(YP,YT)) RETURN 999 F51D07=-1.0E+20 RETURN END C F52 + V OF MIXTURE AT P FUNCTION F52D07(P,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F52D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F52D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) YRL=G16D07(YT) VG=1E-3/REAL(YRG) VL=1E-3/REAL(YRL) F52D07=VL+X*(VG-VL) ENDIF RETURN END C F53 + V OF SATURATED LIQUID AT T FUNCTION F53D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F53D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRL=G16D07(YT) F53D07=1E-3/REAL(YRL) ENDIF RETURN END C F54 + V OF SATURATED GAS AT T FUNCTION F54D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F54D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) F54D07=1E-3/REAL(YRG) ENDIF RETURN END C F55 + V OF MIXTURE AT T FUNCTION F55D07(T,X) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F55D07=-1.0E+20 ELSEIF (X.LT.0 .OR. X.GT.1) THEN F55D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRL=G16D07(YT) YRG=G15D07(YT) VL=1E-3/REAL(YRL) VG=1E-3/REAL(YRG) F55D07=VL+X*(VG-VL) ENDIF RETURN END C F56 + DRYNESS FRACTION <-> AT P,H FUNCTION F56D07(P,H) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN T=F40D07(P) F56D07=F60D07(T,H) ELSE F56D07=-1.0E+20 ENDIF RETURN END C F57 + DRYNESS FRACTION <-> AT P,S FUNCTION F57D07(P,S) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN T=F40D07(P) F57D07=F61D07(T,S) ELSE F57D07=-1.0E+20 ENDIF RETURN END C F58 + DRYNESS FRACTION <-> AT P,U FUNCTION F58D07(P,U) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN T=F40D07(P) F58D07=F62D07(T,U) ELSE F58D07=-1.0E+20 ENDIF RETURN END C F59 + DRYNESS FRACTION <-> AT P,V FUNCTION F59D07(P,V) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN T=F40D07(P) F59D07=F63D07(T,V) ELSE F59D07=-1.0E+20 ENDIF RETURN END C F60 + DRYNESS FRACTION <-> AT T,H FUNCTION F60D07(T,H) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN HL=F27D07(T) HG=F28D07(T) IF (HL.EQ.HG) THEN F60D07=-1.0E+20 ELSEIF (H.LT.HL .OR. H.GT.HG) THEN F60D07=-1.0E+20 ELSE F60D07=(H-HL)/(HG-HL) ENDIF ELSE F60D07=-1.0E+20 ENDIF RETURN END C F61 + DRYNESS FRACTION <-> AT T,S FUNCTION F61D07(T,S) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN SL=F37D07(T) SG=F38D07(T) IF (SL.EQ.SG) THEN F61D07=-1.0E+20 ELSEIF (S.LT.SL .OR. S.GT.SG) THEN F61D07=-1.0E+20 ELSE F61D07=(S-SL)/(SG-SL) ENDIF ELSE F61D07=-1.0E+20 ENDIF RETURN END C F62 + DRYNESS FRACTION <-> AT T,U FUNCTION F62D07(T,U) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN UL=F46D07(T) UG=F47D07(T) IF (UL.EQ.UG) THEN F62D07=-1.0E+20 ELSEIF (U.LT.UL .OR. U.GT.UG) THEN F62D07=-1.0E+20 ELSE F62D07=(U-UL)/(UG-UL) ENDIF ELSE F62D07=-1.0E+20 ENDIF RETURN END C F63 + DRYNESS FRACTION <-> AT T,V FUNCTION F63D07(T,V) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN VL=F53D07(T) VG=F54D07(T) IF (VL.EQ.VG) THEN F63D07=-1.0E+20 ELSEIF (V.LT.VL .OR. V.GT.VG) THEN F63D07=-1.0E+20 ELSE F63D07=(V-VL)/(VG-VL) ENDIF ELSE F63D07=-1.0E+20 ENDIF RETURN END C F64 + TEMPERATURE AT P AND H FUNCTION F64D07(P,H) DOUBLE PRECISION PP,HH,TT,RR,SS IF (P.LT.0.6601E-2 .OR. P.GT.1000.) THEN F64D07=-1.0E+20 ELSE PC=216.6E+00 HC=0.1965720E+07+1.417202E+01 DP=ABS(1.0E+00-P/PC) DH=ABS(1.0E+00-H/HC) IF (DP.LT.1.0E-05 .AND. DH.LT.1.0E-05) THEN C *** CRITICAL POINT *** F64D07=370.74 ELSE PP=DBLE(P)*1.0D-01 HH=(DBLE(H)-1.417202D+01)*1D-03 CALL S3D07(PP,HH,TT,RR,SS) T=REAL(TT) IF (T.GE.-1.0) THEN F64D07=T-273.15 ELSE F64D07=T ENDIF ENDIF ENDIF RETURN END C F65 + TEMPERATURE AT P AND S FUNCTION F65D07(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH IF (P.LT.0.6601E-2 .OR. P.GT.1000.) THEN F65D07=-1.0E+20 ELSE PC=216.6E+00 SC=0.4181542E+04 DP=ABS(1.0E+00-P/PC) DS=ABS(1.0E+00-S/SC) IF (DP.LT.1.0E-05 .AND. DS.LT.1.0E-05) THEN C *** CRITICAL POINT *** F65D07=370.74 ELSE PP=DBLE(P)*1.0D-01 SS=DBLE(S)*1.0D-03 CALL S2D07(PP,SS,TT,RR,HH) T=REAL(TT) IF (T.GE.-1.0) THEN F65D07=T-273.15 ELSE F65D07=T ENDIF ENDIF ENDIF RETURN END C F70 + TEMPERATURE AT P AND V FUNCTION F70D07(P,V) IMPLICIT DOUBLE PRECISION (G,Y) IF(P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 YP=DBLE(P)*1.0D-01 YR=1D-3/DBLE(V) T=REAL(G2D07(YP,YR)) IF (T.GE.-1.0) THEN F70D07=T-273.15 ELSE F70D07=T ENDIF RETURN 999 F70D07=-1.0E+20 RETURN END C F71 + H AT P AND S FUNCTION F71D07(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH IF (P.LT.0.6601E-2 .OR. P.GT.1000.) THEN F71D07=-1.0E+20 ELSE PC=216.6E+00 SC=0.4181542E+04 DP=ABS(1.0E+00-P/PC) DS=ABS(1.0E+00-S/SC) IF (DP.LT.1.0E-05 .AND. DS.LT.1.0E-05) THEN C *** CRITICAL POINT *** F71D07=0.1965720E+07+1.417202E+01 ELSE PP=DBLE(P)*1.0D-01 SS=DBLE(S)*1.0D-03 CALL S2D07(PP,SS,TT,RR,HH) H=REAL(HH) IF (H.GE.-1E8) THEN F71D07=REAL(HH)*1E3+1.417202E+01 ELSE F71D07=H ENDIF ENDIF ENDIF RETURN END C FA1 + CV OF SATURATED LIQUID AT P FUNCTION FA1D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN FA1D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRL=G16D07(YT) FA1D07=REAL(G9D07(YRL,YT))*1E3 ENDIF RETURN END C F76 + CV OF SATURATED VAPOUR AT P FUNCTION F76D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.3) THEN F76D07=-1.0E+20 ELSE YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) F76D07=REAL(G9D07(YRG,YT))*1E3 ENDIF RETURN END C F77 + CV AT P AND T FUNCTION F77D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) F77D07=REAL(G9D07(YR,YT))*1E3 RETURN 999 F77D07=-1.0E+20 RETURN END C FA2 + CV OF SATURATED LIQUID AT T FUNCTION FA2D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN FA2D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRL=G16D07(YT) FA2D07=REAL(G9D07(YRL,YT))*1E3 ENDIF RETURN END C F78 + CV OF SATURATED VAPOUR AT T FUNCTION F78D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.3) THEN F78D07=-1.0E+20 ELSE YT=DBLE(T+273.15) YRG=G15D07(YT) F78D07=REAL(G9D07(YRG,YT))*1E3 ENDIF RETURN END C F79 + U AT P AND S FUNCTION F79D07(P,S) IMPLICIT DOUBLE PRECISION (G) DOUBLE PRECISION PP,SS,TT,RR,HH IF (P.LT.0.6601E-2 .OR. P.GT.1000.) THEN F79D07=-1.0E+20 ELSE PC=216.6E+00 SC=0.4181542E+04 DP=ABS(1.0E+00-P/PC) DS=ABS(1.0E+00-S/SC) IF (DP.LT.1.0E-05 .AND. DS.LT.1.0E-05) THEN C *** CRITICAL POINT *** F79D07=0.1905217E+07+1.417202E+01 ELSE PP=DBLE(P)*1.0D-01 SS=DBLE(S)*1.0D-03 CALL S2D07(PP,SS,TT,RR,HH) IF (RR.GE.-1D8) THEN F79D07=REAL(G6D07(RR,TT))*1E3+1.417202E+01 ELSE F79D07=REAL(RR) ENDIF ENDIF ENDIF RETURN END C F80 + V AT P AND S FUNCTION F80D07(P,S) DOUBLE PRECISION PP,SS,TT,RR,HH IF (P.LT.0.6601E-2 .OR. P.GT.1000.) THEN F80D07=-1.0E+20 ELSE PC=216.6E+00 SC=0.4181542E+04 DP=ABS(1.0E+00-P/PC) DS=ABS(1.0E+00-S/SC) IF (DP.LT.1.0E-05 .AND. DS.LT.1.0E-05) THEN C *** CRITICAL POINT *** F80D07=1.0E-03/0.358E+00 ELSE PP=DBLE(P)*1.0D-01 SS=DBLE(S)*1.0D-03 CALL S2D07(PP,SS,TT,RR,HH) R=REAL(RR) IF (R.GE.-1E8) THEN F80D07=1E-3/R ELSE F80D07=R ENDIF ENDIF ENDIF RETURN END C F81 + PR<-> AT P AND T FUNCTION F81D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D07 IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.500.) GOTO 999 IF (G93D07(P,T).EQ.2) THEN YP=DBLE(P*0.1) YT=DBLE(T+273.15) YR=G7D07(YP,YT) YRR=YR*1D3 YCP=G8D07(YR,YT) ALM=REAL(G51D07(YRR,YT)) IF (ALM.EQ.-1.0E+20) THEN F81D07=ALM ELSE F81D07=REAL(YCP*1D3*G50D07(YRR,YT))/ALM ENDIF RETURN ENDIF 999 F81D07=-1.0E+20 RETURN END C F82 + KAPPA<-> AT P AND T FUNCTION F82D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) WPT=REAL(G10D07(YR,YT)) F82D07=REAL(YR/YP)*WPT**2*1.0E-03 RETURN 999 F82D07=-1.0E+20 RETURN END C F83 + W AT P AND T FUNCTION F83D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) F83D07=REAL(G10D07(YR,YT)) RETURN 999 F83D07=-1.0E+20 RETURN END C 85 ***** PRPD(P) FUNCTION F85D07(P) CONDUC=F6D07(P) IF (CONDUC.EQ.-1.0E+20) THEN F85D07=-1.0E+20 ELSE VISCOS=F11D07(P) CP=F16D07(P) F85D07=CP*VISCOS/CONDUC ENDIF RETURN END C 86 ***** PRPDD(P) FUNCTION F86D07(P) CONDUC=F7D07(P) IF (CONDUC.EQ.-1.0E+20) THEN F86D07=-1.0E+20 ELSE VISCOS=F12D07(P) CP=F17D07(P) F86D07=CP*VISCOS/CONDUC ENDIF RETURN END C 87 ***** FUNCTION F87D07(T) CONDUC=F9D07(T) IF (CONDUC.EQ.-1.0E+20) THEN F87D07=-1.0E+20 ELSE VISCOS=F14D07(T) CP=F19D07(T) F87D07=CP*VISCOS/CONDUC ENDIF RETURN END C 88 ***** FUNCTION F88D07(T) CONDUC=F10D07(T) IF (CONDUC.EQ.-1.0E+20) THEN F88D07=-1.0E+20 ELSE VISCOS=F15D07(T) CP=F20D07(T) F88D07=CP*VISCOS/CONDUC ENDIF RETURN END C F90 + BSPT<1/PA> AT P AND T FUNCTION F90D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) SS=REAL(G10D07(YR,YT)) VV=1.0E-03/REAL(YR) F90D07=VV/SS**2 RETURN 999 F90D07=-1.0E+20 RETURN END C F91 + BTPT<1/PA> AT P AND T FUNCTION F91D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D07 IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 IF (G93D07(P,T).EQ.2) THEN YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) DPDR=REAL(G34D07(YR,YT))*1.0E+06 F91D07=1.0E+00/REAL(YR)/DPDR ELSE F91D07=-1.0E+20 ENDIF RETURN 999 F91D07=-1.0E+20 RETURN END C F92 + BPPT<1/K> AT P AND T FUNCTION F92D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G93D07 IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 IF (G93D07(P,T).EQ.2) THEN YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) F92D07=REAL(G33D07(YR,YT)/YR/G34D07(YR,YT)) ELSE F92D07=-1.0E+20 ENDIF RETURN 999 F92D07=-1.0E+20 RETURN END C F93 + BVPT<1/K> AT P AND T FUNCTION F93D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) F93D07=REAL(G33D07(YR,YT)/YP) RETURN 999 F93D07=-1.0E+20 RETURN END C F94 + AJTPT AT P AND T FUNCTION F94D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) YDPDT=G33D07(YR,YT) YY=YT*YDPDT/(YR*G34D07(YR,YT))-1.0D+00 DPDTDR=REAL(YY) YCP=G8D07(YR,YT) IF (YCP.EQ.-1.0E+20) THEN F94D07=1.0E-06/REAL(YDPDT) ELSE F94D07=1.0E-06*DPDTDR/REAL(YR*YCP) ENDIF RETURN 999 F94D07=-1.0E+20 RETURN END C F95 + RATIO OF SPECIFIC HEATS AT P AND T FUNCTION F95D07(P,T) IMPLICIT DOUBLE PRECISION (G,Y) IF (P.LT.0.6601E-2 .OR. P.GT.1000.) GOTO 999 IF (T.LT.3.8 .OR. T.GT.800.) GOTO 999 YT=DBLE(T+273.15) YP=DBLE(P*0.1) YR=G7D07(YP,YT) YCP=G8D07(YR,YT) IF (YCP.LT.-1.0E+08) THEN F95D07=-1.0E+20 ELSE F95D07=REAL(YCP/G9D07(YR,YT)) ENDIF RETURN 999 F95D07=-1.0E+20 RETURN END C F96 + RATIO OF SPECIFIC HEATS OF SATURATED VAPOUR AT P FUNCTION F96D07(P) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G91D07 IF (G91D07(P).EQ.0) THEN YP=DBLE(P*0.1) YT=G13D07(YP) YRG=G15D07(YT) YCP=G8D07(YRG,YT) IF (YCP.LT.-1.0E+08) THEN F96D07=-1.0E+20 ELSE F96D07=REAL(YCP/G9D07(YRG,YT)) ENDIF ELSE F96D07=-1.0E+20 ENDIF RETURN END C F97 + RATIO OF SPECIFIC HEATS OF SATURATED VAPOUR AT T FUNCTION F97D07(T) IMPLICIT DOUBLE PRECISION (G,Y) INTEGER G92D07 IF (G92D07(T).EQ.0) THEN YT=DBLE(T+273.15) YRG=G15D07(YT) YCP=G8D07(YRG,YT) IF (YCP.LT.-1.0E+08) THEN F97D07=-1.0E+20 ELSE F97D07=REAL(YCP/G9D07(YRG,YT)) ENDIF ELSE F97D07=-1.0E+20 ENDIF RETURN END C F98 + PSEUDO BOILING POINT AT P FUNCTION F98D07(P) DIMENSION T(2),C(2),TL(3),TR(3),CL(3),CR(3) P1=F21D07('P') PP=ABS((P-P1)/P1) T1=F21D07('T') IF (PP.LT.1.0E-5) THEN F98D07=T1 RETURN ENDIF IF (P.LT.P1.OR.P.GT.500.001D00) THEN F98D07=-1.0E+20 RETURN ENDIF T2=0.85*T1 P2=F30D07(T2) TM0=T1+(T1-T2)*(P-P1)/(P1-P2) C-----TM0 KINJICHI TC=T1 T(1)=TM0 150 EPS=1.0E-6 DEL=T1*0.05 IREP=0 IREM=5000 KCONT=0 ICONT=0 C(1)=F18D07(P,T(1)) T(2)=T(1)-DEL C(2)=F18D07(P,T(2)) 1000 RINC=C(2)-C(1) IF(RINC.GT.0.3)THEN GOTO 1500 ELSE T(2)=T(1) C(2)=C(1) T(1)=T(1)-DEL C(1)=F18D07(P,T(1)) GOTO 1000 ENDIF 1500 C(1)=-C(1) C(2)=-C(2) 2000 IREP=IREP+1 IF(IREP.GT.IREM) GO TO 8000 TT=T(2)+1.3*(T(2)-T(1)) CC=-F18D07(P,TT) 3000 CONV=ABS((CC-C(2))/CC) IF(CONV.LT.EPS) THEN F98D07=TT RETURN ENDIF 4000 DEC=C(1)-CC ICONT=ICONT+1 IF(DEC.GE.0.0) THEN T(1)=TT C(1)=CC ELSE IF (ICONT.GT.5) GO TO 6000 TT=(TT+T(2))*0.5 CC=-F18D07(P,TT) GOTO 4000 ENDIF 5000 DEC=C(1)-C(2) IF(DEC.LT.0.0) THEN TT=T(1) CC=C(1) T(1)=T(2) C(1)=C(2) T(2)=TT C(2)=CC ENDIF GOTO 2000 6000 TA=T(1) TB=TT IF (TB.LT.TA) THEN TA=TT TB=T(1) ENDIF TC=TA+0.5*(TB-TA) CA=F18D07(P,TA) CB=F18D07(P,TB) 6050 KCONT=KCONT+1 IF (KCONT.GT.IREM) GO TO 8000 DELT=ABS((TA-TB)/TA) IF (DELT.LT.EPS) GO TO 7000 CC=F18D07(P,TC) DTA=(TC-TA)*0.3 TL(1)=TA TL(2)=TC-DTA TL(3)=TC DTB=(TB-TC)*0.3 TR(1)=TC TR(2)=TC+DTB TR(3)=TB CL(1)=CA CL(3)=CC CR(1)=CC CR(3)=CB CL(2)=F18D07(P,TL(2)) CR(2)=F18D07(P,TR(2)) CMXL=CL(1) ML=1 DO 6120 I=2,3 IF(CL(I).GT.CMXL) THEN CMXL=CL(I) ML=I ENDIF 6120 CONTINUE CMXR=CR(1) MR=1 DO 6130 I=2,3 IF(CR(I).GT.CMXR) THEN CMXR=CR(I) MR=I ENDIF 6130 CONTINUE IF(CMXL.GT.CMXR) THEN IF(ML.EQ.1) THEN TA=TL(1)-DTA CA=F18D07(P,TA) ELSE TA=TL(ML-1) CA=CL(ML-1) ENDIF IF(ML.EQ.3) THEN TB=TR(2) CB=CR(2) ELSE TB=TL(ML+1) CB=CL(ML+1) ENDIF TC=TL(ML) CC=CL(ML) ELSE IF(MR.EQ.1) THEN TA=TL(2) CA=CL(2) ELSE TA=TR(MR-1) CA=CR(MR-1) ENDIF IF(MR.EQ.3) THEN TB=TR(3)+DTB CB=F18D07(P,TB) ELSE TB=TR(MR+1) CB=CR(MR+1) ENDIF 6135 TC=TR(MR) CC=CR(MR) ENDIF GO TO 6050 7000 F98D07=TC RETURN 8000 F98D07=-1.0E+10 RETURN END C ****************************************** C * THEMOPHYSICAL PROPERTIES * C * OF HEAVY WATER * C * FOR PROPATH VER.6.1 * C * * C * CITED FROM * C * * C * P.G.HILL,R.D.MACMILLAN AND V.LEE, * C * * C * TABLES OF THERMOPHYSICAL PROPERTIES * C * OF HEAVY WATER IN S.I. UNITS * C * * C * ATOMIC ENERGY OF CANADA LIMITED, * C * MISSISSAUGA, ONTARIO, 1981 * C * * C * CODED (MARCH 1989) * C * BY * C * TAMAMI FUJINO * C * * C * REVISED BY TOMOHIRO HONDA * C * * C * FUKUOKA UNIVERSITY * C * FUKUOKA, 814-01, JAPAN * C ****************************************** C G1 ****************************** C ** PRT:PRESSURE ** C ** R: T: ** C ****************************** FUNCTION G1D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) GC=0.41515D0 G1D07=R*GC*T*(1D0+R*G21D07(R,T)+R*R*G22D07(R,T)) RETURN END C G2 ******************************* C ** TPR:TEMPERATURE ** C ** P: R: ** C ******************************* FUNCTION G2D07(P,R) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA RC,PC,TC/0.358D+00,21.66D+00,643.89D+00/ DP=DABS(1.0D+00-P/PC) DR=DABS(1.0D+00-R/RC) IF (DP.LT.1.0D-05 .AND. DR.LT.1.0D-05) THEN C *** CRITICAL POINT *** G2D07=TC ELSE ILOOP=0 TMIN=276.95D+00 RMIN=G7D07(P,TMIN) TMAX=1073.15D0 RMAX=G7D07(P,TMAX) IF (R.LT.RMAX .OR. R.GT.RMIN) THEN G2D07=-1.0E+20 ELSE IF (P.GT.21.66D0) THEN TA=TMAX TB=TMIN ELSE TS=G13D07(P) RG=G15D07(TS) RL=G16D07(TS) IF (R.GT.RL) THEN TA=TS TB=TMIN ELSEIF (R.GE.RG) THEN G2D07=TS RETURN ELSE TA=TMAX TB=TS ENDIF ENDIF RA=G7D07(P,TA) RB=G7D07(P,TB) 10 ILOOP=ILOOP+1 TM=TB+(TA-TB)*0.5D+00 RM=G7D07(P,TM) IF (ILOOP.EQ.10000) THEN G2D07=-1.0E+10 ELSEIF (DABS(RA-RB)/RM.LT.1D-8) THEN G2D07=TM ELSE DRA=R-RA DRB=R-RB DRM=R-RM IF (DRA*DRM.LE.0.0 .AND. DRB*DRM.GT.0.0) THEN TB=TM RB=RM ELSEIF (DRA*DRM.GT.0.0 .AND. DRB*DRM.LE.0.0) THEN TA=TM RA=RM ENDIF GOTO 10 ENDIF ENDIF ENDIF RETURN END C G3 ************************************* C ** SRT:SPECIFIC ENTROPY ** C ** R: T: ** C ************************************* FUNCTION G3D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) GC=0.41515D0 G3D07=-GC*(DLOG(R)+R*G21D07(R,T)+R*T*G23D07(R,T))-G24D07(T) RETURN END C G4 *************************************** C ** HRT:SPECIFIC ENTHALPY ** C ** R: T: ** C *************************************** FUNCTION G4D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) GC=0.41515D0 G4D07=GC*T*(1D0+R*G21D07(R,T)-R*T*G23D07(R,T) & +R*R*G22D07(R,T))+G25D07(T) RETURN END C G5 ******************************** C ** ALHT:LATENT HEAT ** C ** T: ** C ******************************** FUNCTION G5D07(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) RG=G15D07(T) RL=G16D07(T) HG=G4D07(RG,T) HL=G4D07(RL,T) G5D07=HG-HL RETURN END C G6 ********************************************* C ** URT:SPECIFIC INTERNAL ENERGY ** C ** R: T: ** C ********************************************* FUNCTION G6D07(R,T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) GC=0.41515D0 TAU=1D3/T G6D07=G25D07(T)+GC*T*R*TAU*G26D07(R,T) RETURN END C G7 ********************************** C ** RPT:DENSITY ** C ** P: T: ** C ********************************** FUNCTION G7D07(P,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA RC,PC,TC/0.358D+00,21.66D+00,643.89D+00/ EPS=1.0D-07 DP=DABS(1.0D+00-P/PC) DT=DABS(1.0D+00-T/TC) IF (DP.LT.1.0D-05 .AND. DT.LT.1.0D-05) THEN C *** CRITICAL POINT *** G7D07=RC RETURN ENDIF IF(T.LE.643.89D0) THEN PS=G12D07(T) IF(P.GT.PS) THEN C *** COMPRESSED LIQUID *** IF(T.LT.323.15) THEN RMIN=1000D-3 ELSE IF(T.LT.523.15) THEN RMIN=900D-3 ELSE IF(T.LT.573.15) THEN RMIN=750D-3 ELSE RMIN=357D-3 END IF RMAX=1D-3/0.0008D0 ELSE C *** SUPERHEATED VAPOR *** RMIN=1D-3/557D0 IF(T.LT.333.15) THEN RMAX=1D-3 ELSE IF(T.LT.353.15) THEN RMAX=2D-3 ELSE IF(T.LT.498.15) THEN RMAX=30D-3 ELSE RMAX=359D-3 END IF ENDIF ELSE RMIN=1D-3/557D0 RMAX=1D-3/0.0008D0 ENDIF CALL S1D07(RMIN,RMAX,EPS,P,T,R) G7D07=R RETURN END C G8 ********************************************* C ** CPRT:ISOBARIC SPECIFIC HEAT ** C ** R: T: ** C ********************************************* FUNCTION G8D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA RC,TC/0.358D+00,643.89D+00/ DR=DABS(1.0D+00-R/RC) DT=DABS(1.0D+00-T/TC) IF (DR.LT.1.0D-05 .AND. DT.LT.1.0D-05) THEN G8D07=-1.0E+20 ELSE G8D07=G9D07(R,T)+T*(G33D07(R,T)/R)**2/G34D07(R,T) ENDIF RETURN END C G9 ********************************************** C ** CVRT:ISOCHORIC SPECIFIC HEAT ** C ** R: T: ** C ********************************************** FUNCTION G9D07(R,T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) GC=0.41515D0 G9D07=G28D07(T)-R*GC*T*(T*G29D07(R,T)+2*G23D07(R,T)) RETURN END C G10 ********************************** C ** SSRT:SPEED OF SOUND ** C ** R: T: ** C ********************************** FUNCTION G10D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DPDR=G34D07(R,T) DPDTR2=(G33D07(R,T)/R)**2 CVRT=G9D07(R,T) G10D07=DSQRT((DPDR+T/CVRT*DPDTR2)*1.0D+03) RETURN END C G11 ******************************** C ** SIGT:SURFACE TENTION ** C ** T: ** C ******************************** FUNCTION G11D07(T) T0=643.89E+00 X=(T0-T)/T0 XQT=SQRT(SQRT(X)) G11D07=0.238E-00*X*XQT*(1.0E+00-0.639E+00*X) RETURN END C G12 ************************************** C ** PST : SATURATED PRESSURE ** C ** T : ** C ************************************** FUNCTION G12D07(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA AL1,AL2,AL4,AL11,AL20/ & -7.81583D0,17.6012D0,-18.1747D0,-3.92488D0,4.19174D0/ TC=643.89D0 PC=21.66D0 TAU=1D0-T/TC TAUSQ=DSQRT(TAU) TAUEE=TAU**0.9D+00 TAU2=TAU*TAU TAU4=TAU2*TAU2 GGG=TC/T*(AL1+AL2*TAUEE+AL4*TAU & +(AL11*TAUSQ+AL20*TAU4*TAU)*TAU4)*TAU G12D07=PC*DEXP(GGG) RETURN END C G13 ************************************ C ** TSP:SATURATED TEMPERATURE ** C ** P: ** C ************************************ FUNCTION G13D07(P) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PC,TC/21.66D+00,643.89D+00/ DP=DABS(1.0D+00-P/PC) IF (DP.LT.1.0D-05) THEN G13D07=TC ELSE ILOOP=0 EPS=1D-7 TMAX=643.89D0 TMIN=273.15D0 TA=TMIN TB=TMAX PA=G12D07(TA) PB=G12D07(TB) 10 ILOOP=ILOOP+1 IF(ILOOP.EQ.10000) THEN G13D07=-1.0E+10 ELSE TM=TA+(TB-TA)/2D0 PM=G12D07(TM) DA=P-PA DB=P-PB DM=P-PM IF(DABS(DM/P).LT.EPS) THEN G13D07=TM ELSE IF(DM*DA.LT.0D0) THEN TB=TM PB=PM ELSE IF(DM*DB.LT.0D0) THEN TA=TM PA=PM ELSE TB=TM PB=PM END IF GO TO 10 ENDIF ENDIF ENDIF RETURN END C G14 **************************************** C ** PSTHF:PRESSURE ** C ** BY HELMHOLTZ FREE ENERGY ** C ** T: ** C **************************************** FUNCTION G14D07(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA PC,TC/21.66D+00,643.89D+00/ DT=DABS(1.0D+00-T/TC) IF (DT.LT.1.0D-05) THEN G14D07=PC ELSE RG=G15D07(T) RL=G16D07(T) PSIG=G20D07(RG,T) PSIL=G20D07(RL,T) G14D07=(PSIG-PSIL)*RL*RG/(RG-RL) ENDIF RETURN END C G15 ************************************** C ** RGT:DENSITY ** C ** OF SATURATED VAPOR STATE ** C ** T: ** C ************************************** FUNCTION G15D07(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA RC,TC/0.358D+00,643.89D+00/ DT=DABS(T/TC-1.0D+00) IF (DT.LE.1.0D-05) THEN G15D07=RC ELSE P=G12D07(T) RMIN=1D-3/174.081D0 RMAX=RC IF(T.LE.573.15D0) THEN C ***** NEWTON ***** R1=RMIN EPS1=1.0D-07 ILOOP=0 10 ILOOP=ILOOP+1 IF(ILOOP.EQ.10000) THEN G15D07=-1.0E+10 ELSE R2=R1+(P-G1D07(R1,T))/G34D07(R1,T) IF(DABS((R2-R1)/R2).LT.EPS1) THEN G15D07=R2 ELSE R1=R2 GO TO 10 ENDIF ENDIF ELSE C ***** NIBUN ***** RA=RMIN RB=RMAX PA=G1D07(RA,T) PB=G1D07(RB,T) EPS2=1.0D-05 JLOOP=0 70 JLOOP=JLOOP+1 IF(JLOOP.EQ.10000) THEN G15D07=-1.0E+10 ELSE RM=RA+0.5D+00*(RB-RA) PM=G1D07(RM,T) DA=P-PA DB=P-PB DM=P-PM IF(DABS(DM/P).LT.EPS2) THEN G15D07=RM ELSE IF(DM*DA.LT.0D0) THEN RB=RM PB=PM ELSEIF(DM*DB.LT.0D0) THEN RA=RM PA=PM ELSEIF((PM.GT.PB).AND.(PM.GT.PA).AND.(PB.GT.PA)) THEN RA=RM PA=PM ELSEIF((PM.GT.PB).AND.(PM.GT.PA).AND.(PB.LT.PA)) THEN RB=RM PB=PM ELSE RA=RM PA=PM END IF GO TO 70 ENDIF ENDIF ENDIF ENDIF RETURN END C G16 ************************************** C ** RLT:DENSITY ** C ** OF SATURATED LIQUID STATE ** C ** T: ** C ************************************** FUNCTION G16D07(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA RC,TC/0.358D+00,643.89D+00/ DT=DABS(1.0D+00-T/TC) IF (DT.LE.1.0D-05) THEN G16D07=RC ELSE P=G12D07(T) EPS=1D-7 RMAX=1D-3/0.0009046D0 RMIN=RC IF(T.GT.473.15D0) THEN C ***** NIBUN ***** CALL S1D07(RMIN,RMAX,EPS,P,T,R) G16D07=R ELSE C ***** NEWTON ***** R1=RMAX ILOOP=0 10 ILOOP=ILOOP+1 IF(ILOOP.EQ.10000) THEN G16D07=-1.0E+10 ELSE R2=R1+(P-G1D07(R1,T))/G34D07(R1,T) IF(DABS((R2-R1)/R2).LT.EPS) THEN G16D07=R2 ELSE R1=R2 GO TO 10 ENDIF ENDIF ENDIF ENDIF RETURN END C G17 ************************************** C ** ALAPT:LAPLACE COEFFICIENT ** C ** T: ** C ************************************** FUNCTION G17D07(YT) DOUBLE PRECISION G15D07,G16D07,YT RL=REAL(G16D07(YT)) RG=REAL(G15D07(YT)) IF (RL.EQ.RG) THEN G17D07=0.0 ELSE T=REAL(YT) SIG=G11D07(T) RV=(RL-RG)*1.0E+03 G17D07=SQRT(SIG/RV/9.80665D+00) ENDIF RETURN END C G20 **************************************** C ** PSI:SPECIFIC HELMHOLTZ FREE ENERGY ** C ** ** C ** R: T: ** C **************************************** FUNCTION G20D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA C1,C2,C3,C4,C5,C6,C7,C8 & / 1866.73D0 , 4661.9D0 , 64.605D0 , -284.8833D0, & 100.1333D0, -13.135D0 , 0.32684D0,-1211.253D0/ GC=0.41515D0 TD3=T/1.0D+03 TLG=DLOG(T) PSI0=C1+(C2+(C3+(C4+(C5+C6*TD3)*TD3)*TD3)*TD3)*TD3 PSI0=PSI0+C7*TLG+C8*TD3*TLG G20D07=PSI0+GC*T*(DLOG(R)+R*G21D07(R,T)) RETURN END C G21 ****************************** C ** Q ** C ** R: T: ** C ****************************** FUNCTION G21D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION TAUA(7),RA(7) DATA A11,A21,A31,A41,A51,A61,A71,A81,A91,A101, & A12,A22,A32,A42,A52,A62,A72,A82,A92,A102 & / 73.13848592D0, -285.20415917D0, 535.71659288D0, & -649.81000614D0, 574.63280680D0, -387.92157774D0, & 206.34569512D0, -79.89428513D0, -996.36169097D0, & -766.27290006D0, 24.74108348D0, -105.57317181D0, & 200.87302906D0, -235.18776440D0, 224.56976938D0, & -40.09924297D0, 128.77154771D0, -28.40907978D0, & -1389.08003142D0,-1672.09705556D0/ DATA B11,B21,B31,B41,B51,B61,B12,B22,B32,B42,B52,B62, & B13,B23,B33,B43,B53,B63 & / 11.64775625D0, -42.51820251D0, 72.45541064D0, & -82.55391089D0, -267.85482520D0, -998.64982710D0, & 2.66566642D0, -9.19657655D0, 15.13096920D0, & -7.24860975D0, -46.83904320D0, -227.34793319D0, & -6.73408249D0, 24.03602093D0, -41.08079830D0, & 45.39111005D0, 139.21659329D0, 566.02305152D0/ DATA B14,B24,B34,B44,B54,B64,B15,B25,B35,B45,B55,B65 & / -5.24802962D0, 18.52690633D0, -31.42397369D0, & 26.43208802D0, 96.31411481D0, 453.20280933D0, & -1.17583447D0, 4.13816432D0, -6.55842224D0, & 4.75774631D0, 19.39184297D0, 103.56819758D0/ DATA TAUA/1.553D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0/ DATA RA/0.7D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0/ TAU=1.0D+03/T TAUC=1.553D0 E=4.3D0 ERR=DEXP(-1.0D+00*E*R) QQQ=0.0D+00 Q1=1.0D+00/(TAU-TAUA(1)) RRA=R-RA(1) Q2=A11+(A21+(A31+(A41+(A51+(A61+(A71+A81*RRA)*RRA) & *RRA)*RRA)*RRA)*RRA)*RRA+ERR*(A91+A101*R) QQQ=QQQ+Q1*Q2 Q1=1.0D+00 RRA=R-RA(2) Q2=A12+(A22+(A32+(A42+(A52+(A62+(A72+A82*RRA)*RRA) & *RRA)*RRA)*RRA)*RRA)*RRA+ERR*(A92+A102*R) QQQ=QQQ+Q1*Q2 Q1=TAU-TAUA(3) RRA=R-RA(3) Q2=B11+(B21+(B31+B41*RRA)*RRA)*RRA+ERR*(B51+B61*R) QQQ=QQQ+Q1*Q2 Q1=(TAU-TAUA(4))**2 RRA=R-RA(4) Q2=B12+(B22+(B32+B42*RRA)*RRA)*RRA+ERR*(B52+B62*R) QQQ=QQQ+Q1*Q2 Q1=(TAU-TAUA(5))**3 RRA=R-RA(5) Q2=B13+(B23+(B33+B43*RRA)*RRA)*RRA+ERR*(B53+B63*R) QQQ=QQQ+Q1*Q2 Q1=(TAU-TAUA(6))**4 RRA=R-RA(6) Q2=B14+(B24+(B34+B44*RRA)*RRA)*RRA+ERR*(B54+B64*R) QQQ=QQQ+Q1*Q2 Q1=(TAU-TAUA(7))**5 RRA=R-RA(7) Q2=B15+(B25+(B35+B45*RRA)*RRA)*RRA+ERR*(B55+B65*R) G21D07=(TAU-TAUC)*(QQQ+Q1*Q2) RETURN END C G22 ****************************** C ** DQDR : DQ/DR ** C ** R: T: ** C ****************************** FUNCTION G22D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION TAUA(7),RA(7) DATA A11,A21,A31,A41,A51,A61,A71,A81,A91,A101, & A12,A22,A32,A42,A52,A62,A72,A82,A92,A102 &/ 73.13848592D0, -285.20415917D0, 535.71659288D0, & -649.81000614D0, 574.63280680D0, -387.92157774D0, & 206.34569512D0, -79.89428513D0, -996.36169097D0, & -766.27290006D0, 24.74108348D0, -105.57317181D0, & 200.87302906D0, -235.18776440D0, 224.56976938D0, & -40.09924297D0, 128.77154771D0, -28.40907978D0, & -1389.08003142D0,-1672.09705556D0/ DATA B11,B21,B31,B41,B51,B61,B12,B22,B32,B42,B52,B62, & B13,B23,B33,B43,B53,B63 &/ 11.64775625D0, -42.51820251D0, 72.45541064D0, & -82.55391089D0, -267.85482520D0, -998.64982710D0, & 2.66566642D0, -9.19657655D0, 15.13096920D0, & -7.24860975D0, -46.83904320D0, -227.34793319D0, & -6.73408249D0, 24.03602093D0, -41.08079830D0, & 45.39111005D0, 139.21659329D0, 566.02305152D0/ DATA B14,B24,B34,B44,B54,B64,B15,B25,B35,B45,B55,B65 &/ -5.24802962D0, 18.52690633D0, -31.42397369D0, & 26.43208802D0, 96.31411481D0, 453.20280933D0, & -1.17583447D0, 4.13816432D0, -6.55842224D0, & 4.75774631D0, 19.39184297D0, 103.56819758D0/ DATA TAUA/1.553D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0/ DATA RA/0.7D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0/ TAU=1.0D+03/T TAUC=1.553D+00 E=4.3D+00 ERR=DEXP(-1.0D+00*E*R) ER1=1.0D+00-E*R DQDR=0.0D+00 DR1=1.0D+00/(TAU-TAUA(1)) RRA=R-RA(1) DR2=A21+(2*A31+(3*A41+(4*A51+(5*A61+(6*A71+7*A81*RRA) & *RRA)*RRA)*RRA)*RRA)*RRA+ERR*(A101*ER1-E*A91) DQDR=DQDR+DR1*DR2 DR1=1.0D+00 RRA=R-RA(2) DR2=A22+(2*A32+(3*A42+(4*A52+(5*A62+(6*A72+7*A82*RRA) & *RRA)*RRA)*RRA)*RRA)*RRA+ERR*(A102*ER1-E*A92) DQDR=DQDR+DR1*DR2 DR1=TAU-TAUA(3) RRA=R-RA(3) DR2=B21+(2*B31+3*B41*RRA)*RRA+ERR*(B61*ER1-E*B51) DQDR=DQDR+DR1*DR2 DR1=(TAU-TAUA(4))**2 RRA=R-RA(4) DR2=B22+(2*B32+3*B42*RRA)*RRA+ERR*(B62*ER1-E*B52) DQDR=DQDR+DR1*DR2 DR1=(TAU-TAUA(5))**3 RRA=R-RA(5) DR2=B23+(2*B33+3*B43*RRA)*RRA+ERR*(B63*ER1-E*B53) DQDR=DQDR+DR1*DR2 DR1=(TAU-TAUA(6))**4 RRA=R-RA(6) DR2=B24+(2*B34+3*B44*RRA)*RRA+ERR*(B64*ER1-E*B54) DQDR=DQDR+DR1*DR2 DR1=(TAU-TAUA(7))**5 RRA=R-RA(7) DR2=B25+(2*B35+3*B45*RRA)*RRA+ERR*(B65*ER1-E*B55) G22D07=(TAU-TAUC)*(DQDR+DR1*DR2) RETURN END C G23 ****************************** C ** DQDT : DQ/DT ** C ** R: T: ** C ****************************** FUNCTION G23D07(R,T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) G23D07=-1D3/T/T*G26D07(R,T) RETURN END C G24 ****************************** C ** DPSDT : DPSI0/DT ** C ** T : ** C ****************************** FUNCTION G24D07(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA C2,C3,C4,C5,C6,C7,C8 & / 4661.9D-03, 64.605D-03, -284.8833D-03, & 100.1333D-03, -13.135D-03, 0.32684D0,-1211.253D-03/ TD3=T/1.0D+03 TLG=DLOG(T) DPSDT=C2+(2*C3+(3*C4+(4*C5+5*C6*TD3)*TD3)*TD3)*TD3 G24D07=DPSDT+C7/T+C8*(TLG+1D0) RETURN END C G25 ****************************** C ** DPST : D(PSI0*TAU)/DT ** C ** T: ** C ****************************** FUNCTION G25D07(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA C1,C3,C4,C5,C6,C7,C8 & /1866.73D0 , 64.605D0 , -284.8833D0, & 100.1333D0, -13.135D0 , 0.32684D0,-1211.253D0/ TAU=1D3/T TAR=1.0D+00/TAU DPST=C1-(C3+(2*C4+(3*C5+4*C6*TAR)*TAR)*TAR)*TAR*TAR G25D07=DPST+C7*DLOG(1D3)-C7*DLOG(TAU)-C7-C8*TAR RETURN END C G26 ****************************** C ** DQDTAU : DQ/DTAU ** C ** R: T: ** C ****************************** FUNCTION G26D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION TAUA(7),RA(7) DATA A11,A21,A31,A41,A51,A61,A71,A81,A91,A101, & A12,A22,A32,A42,A52,A62,A72,A82,A92,A102 &/ 73.13848592D0, -285.20415917D0, 535.71659288D0, & -649.81000614D0, 574.63280680D0, -387.92157774D0, & 206.34569512D0, -79.89428513D0, -996.36169097D0, & -766.27290006D0, 24.74108348D0, -105.57317181D0, & 200.87302906D0, -235.18776440D0, 224.56976938D0, & -40.09924297D0, 128.77154771D0, -28.40907978D0, & -1389.08003142D0,-1672.09705556D0/ DATA B11,B21,B31,B41,B51,B61,B12,B22,B32,B42,B52,B62, & B13,B23,B33,B43,B53,B63 &/ 11.64775625D0, -42.51820251D0, 72.45541064D0, & -82.55391089D0, -267.85482520D0, -998.64982710D0, & 2.66566642D0, -9.19657655D0, 15.13096920D0, & -7.24860975D0, -46.83904320D0, -227.34793319D0, & -6.73408249D0, 24.03602093D0, -41.08079830D0, & 45.39111005D0, 139.21659329D0, 566.02305152D0/ DATA B14,B24,B34,B44,B54,B64,B15,B25,B35,B45,B55,B65 &/ -5.24802962D0, 18.52690633D0, -31.42397369D0, & 26.43208802D0, 96.31411481D0, 453.20280933D0, & -1.17583447D0, 4.13816432D0, -6.55842224D0, & 4.75774631D0, 19.39184297D0, 103.56819758D0/ DATA TAUA/1.553D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0/ DATA RA/0.7D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0/ TAU=1.0D+03/T TAUC=1.553D0 DTAUC=TAU-TAUC E=4.3D0 ERR=DEXP(-1.0D+00*E*R) RRA=R-RA(2) DQDT=A12+(A22+(A32+(A42+(A52+(A62+(A72+A82*RRA)*RRA) & *RRA)*RRA)*RRA)*RRA)*RRA+ERR*(A92+A102*R) DTA=TAU-TAUA(3) DTAU1=DTA+DTAUC RRA=R-RA(3) DTAU2=B11+(B21+(B31+B41*RRA)*RRA)*RRA+ERR*(B51+B61*R) DQDT=DQDT+DTAU1*DTAU2 DTA=TAU-TAUA(4) DTAU1=(DTA+2*DTAUC)*DTA RRA=R-RA(4) DTAU2=B12+(B22+(B32+B42*RRA)*RRA)*RRA+ERR*(B52+B62*R) DQDT=DQDT+DTAU1*DTAU2 DTA=TAU-TAUA(5) DTAU1=(DTA+3*DTAUC)*DTA**2 RRA=R-RA(5) DTAU2=B13+(B23+(B33+B43*RRA)*RRA)*RRA+ERR*(B53+B63*R) DQDT=DQDT+DTAU1*DTAU2 DTA=TAU-TAUA(6) DTAU1=(DTA+4*DTAUC)*DTA**3 RRA=R-RA(6) DTAU2=B14+(B24+(B34+B44*RRA)*RRA)*RRA+ERR*(B54+B64*R) DQDT=DQDT+DTAU1*DTAU2 DTA=TAU-TAUA(7) DTAU1=(DTA+5*DTAUC)*DTA**4 RRA=R-RA(7) DTAU2=B15+(B25+(B35+B45*RRA)*RRA)*RRA+ERR*(B55+B65*R) G26D07=DQDT+DTAU1*DTAU2 RETURN END C G27 ****************************** C ** DDQDTR : D**2Q/DTDR ** C ** R: T: ** C ****************************** FUNCTION G27D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION TAUA(7),RA(7) DATA A11,A21,A31,A41,A51,A61,A71,A81,A91,A101, & A12,A22,A32,A42,A52,A62,A72,A82,A92,A102 &/ 73.13848592D0, -285.20415917D0, 535.71659288D0, & -649.81000614D0, 574.63280680D0, -387.92157774D0, & 206.34569512D0, -79.89428513D0, -996.36169097D0, & -766.27290006D0, 24.74108348D0, -105.57317181D0, & 200.87302906D0, -235.18776440D0, 224.56976938D0, & -40.09924297D0, 128.77154771D0, -28.40907978D0, & -1389.08003142D0,-1672.09705556D0/ DATA B11,B21,B31,B41,B51,B61,B12,B22,B32,B42,B52,B62, & B13,B23,B33,B43,B53,B63 &/ 11.64775625D0, -42.51820251D0, 72.45541064D0, & -82.55391089D0, -267.85482520D0, -998.64982710D0, & 2.66566642D0, -9.19657655D0, 15.13096920D0, & -7.24860975D0, -46.83904320D0, -227.34793319D0, & -6.73408249D0, 24.03602093D0, -41.08079830D0, & 45.39111005D0, 139.21659329D0, 566.02305152D0/ DATA B14,B24,B34,B44,B54,B64,B15,B25,B35,B45,B55,B65 &/ -5.24802962D0, 18.52690633D0, -31.42397369D0, & 26.43208802D0, 96.31411481D0, 453.20280933D0, & -1.17583447D0, 4.13816432D0, -6.55842224D0, & 4.75774631D0, 19.39184297D0, 103.56819758D0/ DATA TAUA/1.553D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0/ DATA RA/0.7D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0/ TAU=1.0D+03/T TAUC=1.553D0 DTAUC=TAU-TAUC E=4.3D0 ERR=DEXP(-1.0D+00*E*R) ER1=1.0D+00-E*R RRA=R-RA(2) DQDTR=A22+(2*A32+(3*A42+(4*A52+(5*A62+(6*A72+7*A82*RRA)*RRA) & *RRA)*RRA)*RRA)*RRA+ERR*(ER1*A102-E*A92) DTR1=(TAU-TAUA(3))+DTAUC RRA=R-RA(3) DTR2=B21+(2*B31+3*B41*RRA)*RRA+ERR*(ER1*B61-E*B51) DQDTR=DQDTR+DTR1*DTR2 DTA=TAU-TAUA(4) DTR1=(DTA+2*DTAUC)*DTA RRA=R-RA(4) DTR2=B22+(2*B32+3*B42*RRA)*RRA+ERR*(ER1*B62-E*B52) DQDTR=DQDTR+DTR1*DTR2 DTA=TAU-TAUA(5) DTR1=(DTA+3*DTAUC)*DTA**2 RRA=R-RA(5) DTR2=B23+(2*B33+3*B43*RRA)*RRA+ERR*(ER1*B63-E*B53) DQDTR=DQDTR+DTR1*DTR2 DTA=TAU-TAUA(6) DTR1=(DTA+4*DTAUC)*DTA**3 RRA=R-RA(6) DTR2=B24+(2*B34+3*B44*RRA)*RRA+ERR*(ER1*B64-E*B54) DQDTR=DQDTR+DTR1*DTR2 DTA=TAU-TAUA(7) DTR1=(DTA+5*DTAUC)*DTA**4 RRA=R-RA(7) DTR2=B25+(2*B35+3*B45*RRA)*RRA+ERR*(ER1*B65-E*B55) DQDTR=DQDTR+DTR1*DTR2 G27D07=-TAU/T*DQDTR RETURN END C G28 ************************************* C ** DDPST : D**2(PSI0*TAU)/DTDTAU ** C ** T : ** C ************************************* FUNCTION G28D07(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION C(8) DATA C/ 1866.73D0 , 4661.9D0 , 64.605D0 , -284.8833D0, & 100.1333D0, -13.135D0 , 0.32684D0,-1211.253D0/ TAU=1.0D+03/T DDPST1=0D0 DO 10 I=3,6 10 DDPST1=DDPST1-TAU/T*C(I)*(2-I)*(1-I)*TAU**(-1*I) G28D07=DDPST1+C(7)/T-C(8)/1D3 RETURN END C G29 ****************************** C ** DDQDTT : D**2Q/DT**2 ** C ** R: T: ** C ****************************** FUNCTION G29D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION TAUA(7),RA(7) DATA A11,A21,A31,A41,A51,A61,A71,A81,A91,A101, & A12,A22,A32,A42,A52,A62,A72,A82,A92,A102 &/ 73.13848592D0, -285.20415917D0, 535.71659288D0, & -649.81000614D0, 574.63280680D0, -387.92157774D0, & 206.34569512D0, -79.89428513D0, -996.36169097D0, & -766.27290006D0, 24.74108348D0, -105.57317181D0, & 200.87302906D0, -235.18776440D0, 224.56976938D0, & -40.09924297D0, 128.77154771D0, -28.40907978D0, & -1389.08003142D0,-1672.09705556D0/ DATA B11,B21,B31,B41,B51,B61,B12,B22,B32,B42,B52,B62, & B13,B23,B33,B43,B53,B63 &/ 11.64775625D0, -42.51820251D0, 72.45541064D0, & -82.55391089D0, -267.85482520D0, -998.64982710D0, & 2.66566642D0, -9.19657655D0, 15.13096920D0, & -7.24860975D0, -46.83904320D0, -227.34793319D0, & -6.73408249D0, 24.03602093D0, -41.08079830D0, & 45.39111005D0, 139.21659329D0, 566.02305152D0/ DATA B14,B24,B34,B44,B54,B64,B15,B25,B35,B45,B55,B65 &/ -5.24802962D0, 18.52690633D0, -31.42397369D0, & 26.43208802D0, 96.31411481D0, 453.20280933D0, & -1.17583447D0, 4.13816432D0, -6.55842224D0, & 4.75774631D0, 19.39184297D0, 103.56819758D0/ DATA TAUA/1.553D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0/ DATA RA/0.7D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0/ TAU=1D3/T TAUC=1.553D0 T2E3=2.0D+03/T/T/T T1E6=1.0D+06/T/T/T/T DTAUC=TAU-TAUC E=4.3D0 ERR=DEXP(-1.0D+00*E*R) RRA=R-RA(2) DTT1=T2E3 DTT2=A12+(A22+(A32+(A42+(A52+(A62+(A72+A82*RRA)*RRA) & *RRA)*RRA)*RRA)*RRA)*RRA+ERR*(A92+A102*R) DDQDT=DTT1*DTT2 DTA=TAU-TAUA(3) DTAJ2=1.0D+00/DTA DTT1=T2E3*(DTA+DTAUC)+T1E6*2 RRA=R-RA(3) DTT2=B11+(B21+(B31+B41*RRA)*RRA)*RRA+ERR*(B51+B61*R) DDQDT=DDQDT+DTT1*DTT2 DTA=TAU-TAUA(4) DTT1=T2E3*(DTA+DTAUC*2)*DTA+T1E6*2*(2*DTA+DTAUC) RRA=R-RA(4) DTT2=B12+(B22+(B32+B42*RRA)*RRA)*RRA+ERR*(B52+B62*R) DDQDT=DDQDT+DTT1*DTT2 DTA=TAU-TAUA(5) DTT1=(T2E3*(DTA+DTAUC*3)*DTA+T1E6*3*(2*DTA+2*DTAUC))*DTA RRA=R-RA(5) DTT2=B13+(B23+(B33+B43*RRA)*RRA)*RRA+ERR*(B53+B63*R) DDQDT=DDQDT+DTT1*DTT2 DTA=TAU-TAUA(6) DTAJ2=DTA**2 DTT1=(T2E3*(DTA+DTAUC*4)*DTA+T1E6*4*(2*DTA+3*DTAUC))*DTAJ2 RRA=R-RA(6) DTT2=B14+(B24+(B34+B44*RRA)*RRA)*RRA+ERR*(B54+B64*R) DDQDT=DDQDT+DTT1*DTT2 DTA=TAU-TAUA(7) DTAJ2=DTA**3 DTT1=(T2E3*(DTA+DTAUC*5)*DTA+T1E6*5*(2*DTA+4*DTAUC))*DTAJ2 RRA=R-RA(7) DTT2=B15+(B25+(B35+B45*RRA)*RRA)*RRA+ERR*(B55+B65*R) G29D07=DDQDT+DTT1*DTT2 RETURN END C G30 ****************************** C ** DDQDRR : D**2Q/DR**2 ** C ** R: T: ** C ****************************** FUNCTION G30D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION TAUA(7),RA(7) DATA A11,A21,A31,A41,A51,A61,A71,A81,A91,A101, & A12,A22,A32,A42,A52,A62,A72,A82,A92,A102 & / 73.13848592D0, -285.20415917D0, 535.71659288D0, & -649.81000614D0, 574.63280680D0, -387.92157774D0, & 206.34569512D0, -79.89428513D0, -996.36169097D0, & -766.27290006D0, 24.74108348D0, -105.57317181D0, & 200.87302906D0, -235.18776440D0, 224.56976938D0, & -40.09924297D0, 128.77154771D0, -28.40907978D0, & -1389.08003142D0,-1672.09705556D0/ DATA B11,B21,B31,B41,B51,B61,B12,B22,B32,B42,B52,B62, & B13,B23,B33,B43,B53,B63 &/ 11.64775625D0, -42.51820251D0, 72.45541064D0, & -82.55391089D0, -267.85482520D0, -998.64982710D0, & 2.66566642D0, -9.19657655D0, 15.13096920D0, & -7.24860975D0, -46.83904320D0, -227.34793319D0, & -6.73408249D0, 24.03602093D0, -41.08079830D0, & 45.39111005D0, 139.21659329D0, 566.02305152D0/ DATA B14,B24,B34,B44,B54,B64,B15,B25,B35,B45,B55,B65 &/ -5.24802962D0, 18.52690633D0, -31.42397369D0, & 26.43208802D0, 96.31411481D0, 453.20280933D0, & -1.17583447D0, 4.13816432D0, -6.55842224D0, & 4.75774631D0, 19.39184297D0, 103.56819758D0/ DATA TAUA/1.553D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0,2.53D0/ DATA RA/0.7D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0,1.1D0/ TAU=1000.D0/T TAUC=1.553D0 E=4.3D0 EER=DEXP(-1.0D+00*E*R) EDB=E*E ER2=EDB*R-2*E DRR1=1.0D+00/(TAU-TAUA(1)) RRA=R-RA(1) DRR2=2*A31+(3*2*A41+(4*3*A51+(5*4*A61+(6*5*A71+7*6*A81*RRA) & *RRA)*RRA)*RRA)*RRA+EER*(EDB*A91+ER2*A101) DQDR2=DRR1*DRR2 DRR1=1.0D+00 RRA=R-RA(2) DRR2=2*A32+(3*2*A42+(4*3*A52+(5*4*A62+(6*5*A72+7*6*A82*RRA) & *RRA)*RRA)*RRA)*RRA+EER*(EDB*A92+ER2*A102) DQDR2=DQDR2+DRR1*DRR2 DRR1=TAU-TAUA(3) RRA=R-RA(3) DRR2=2*B31+3*2*B41*RRA+EER*(EDB*B51+ER2*B61) DQDR2=DQDR2+DRR1*DRR2 DRR1=(TAU-TAUA(4))**2 RRA=R-RA(4) DRR2=2*B32+3*2*B42*RRA+EER*(EDB*B52+ER2*B62) DQDR2=DQDR2+DRR1*DRR2 DRR1=(TAU-TAUA(5))**3 RRA=R-RA(5) DRR2=2*B33+3*2*B43*RRA+EER*(EDB*B53+ER2*B63) DQDR2=DQDR2+DRR1*DRR2 DRR1=(TAU-TAUA(6))**4 RRA=R-RA(6) DRR2=2*B34+3*2*B44*RRA+EER*(EDB*B54+ER2*B64) DQDR2=DQDR2+DRR1*DRR2 DRR1=(TAU-TAUA(7))**5 RRA=R-RA(7) DRR2=2*B35+3*2*B45*RRA+EER*(EDB*B55+ER2*B65) G30D07=(TAU-TAUC)*(DQDR2+DRR1*DRR2) RETURN END C G33 ****************************** C ** DPDT : DP/DT ** C ** R: T: ** C ****************************** FUNCTION G33D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) GC=0.41515D0 G33D07=GC*R*(1D0+R*G21D07(R,T)+R*R*G22D07(R,T)) & +GC*R*R*T*(G23D07(R,T)+R*G27D07(R,T)) RETURN END C G34 ****************************** C ** DPDR : DP/DR ** C ** R: T: ** C ****************************** FUNCTION G34D07(R,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) GC=0.41515D0 G34D07=GC*T+GC*R*T*(2D0*G21D07(R,T) & +4D0*R*G22D07(R,T)+R*R*G30D07(R,T)) RETURN END C S1 ****************************** C ** R:DENSITY ** C ** BY NIBUN-HO ** C ** RMIN,RMAX: ** C ** P: T: ** C ****************************** SUBROUTINE S1D07(RMIN,RMAX,EPS,P,T,R) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 RA=RMIN RB=RMAX PA=G1D07(RA,T) PB=G1D07(RB,T) 10 ILOOP=ILOOP+1 IF(ILOOP.GT.10000) THEN R=-1.0E+10 ELSE RM=RA+(RB-RA)/2D0 PM=G1D07(RM,T) DA=P-PA DB=P-PB DM=P-PM IF(DABS(DM/P).LT.EPS) THEN R=RM ELSE IF (DM*DA.LT.0D0) THEN RB=RM PB=PM ELSE IF(DM*DB.LT.0D0) THEN RA=RM PA=PM ELSE RB=RM PB=PM ENDIF GO TO 10 ENDIF ENDIF RETURN END C S2 ************************************** C ** P: S: ** C ** BY NIBUN-HO ** C ** T: R: H: ** C ************************************** SUBROUTINE S2D07(P,S,T,R,H) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 TMIN=276.95D0 TMAX=1073.15D0 RMAX=G7D07(P,TMAX) RMIN=G7D07(P,TMIN) SMAX=G3D07(RMAX,TMAX) SMIN=G3D07(RMIN,TMIN) IF (S.LT.SMIN .OR. S.GT.SMAX) GOTO 999 IF (P.GT.21.660002D0) THEN TA=TMAX TB=TMIN ELSE TS=G13D07(P) RG=G15D07(TS) RL=G16D07(TS) SG=G3D07(RG,TS) SL=G3D07(RL,TS) IF (S.LT.SL) THEN TA=TS TB=TMIN ELSEIF (S.LE.SG) THEN VL=1/RL VG=1/RG X=(S-SL)/(SG-SL) V=VL+X*(VG-VL) HL=G4D07(RL,TS) HG=G4D07(RG,TS) H=HL+X*(HG-HL) T=TS R=1/V RETURN ELSE TA=TMAX TB=TS ENDIF ENDIF RA=G7D07(P,TA) RB=G7D07(P,TB) SA=G3D07(RA,TA) SB=G3D07(RB,TB) 10 DSA=S-SA DSB=S-SB DSAB=SA-SB TC=TB+(TA-TB)*0.5D+00 RC=G7D07(P,TC) SC=G3D07(RC,TC) DSC=S-SC IF (DSA*DSC.LE.0.0 .AND. DSB*DSC.GT.0.0) THEN TB=TC RB=RC SB=SC ELSEIF (DSA*DSC.GT.0.0 .AND. DSB*DSC.LE.0.0) THEN TA=TC RA=RC SA=SC ELSE GOTO 777 ENDIF 777 ILOOP=ILOOP+1 IF (ILOOP.GT.10000) GOTO 888 IF (DABS(DSAB/SC).GT.1D-7) GOTO 10 T=TC R=G7D07(P,T) H=G4D07(R,T) RETURN 888 T=-1.0E+10 R=-1.0E+10 H=-1.0E+10 RETURN 999 T=-1.0E+20 R=-1.0E+20 H=-1.0E+20 RETURN END C S3 ***************************************** C ** P: H: ** C ** BY NIBUN-HO ** C ** T: R: S: ** C ***************************************** SUBROUTINE S3D07(P,H,T,R,S) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ILOOP=0 TMIN=276.95D0 TMAX=1073.15D0 RMAX=G7D07(P,TMAX) RMIN=G7D07(P,TMIN) HMAX=G4D07(RMAX,TMAX) HMIN=G4D07(RMIN,TMIN) IF (H.LT.HMIN .OR. H.GT.HMAX) GOTO 999 IF ( P.LT.0.6601D-3 .OR. P.GT.21.660002D0) THEN TA=TMAX TB=TMIN ELSE TS=G13D07(P) RG=G15D07(TS) RL=G16D07(TS) HG=G4D07(RG,TS) HL=G4D07(RL,TS) IF (H.LT.HL) THEN TA=TS TB=TMIN ELSEIF (H.LE.HG) THEN VL=1/RL VG=1/RG X=(H-HL)/(HG-HL) V=VL+X*(VG-VL) SL=G3D07(RL,TS) SG=G3D07(RG,TS) S=SL+X*(SG-SL) T=TS R=1/V RETURN ELSE TA=TMAX TB=TS ENDIF ENDIF RA=G7D07(P,TA) RB=G7D07(P,TB) IF (RA.LT.0.OR.RB.LT.0) GO TO 888 HA=G4D07(RA,TA) HB=G4D07(RB,TB) 10 DHA=H-HA DHB=H-HB DHAB=HA-HB TC=TB+(TA-TB)*.5 RC=G7D07(P,TC) IF (RC.LT.0) GO TO 888 HC=G4D07(RC,TC) DHC=H-HC IF (DHA*DHC.LE.0.0 .AND. DHB*DHC.GT.0.0) THEN TB=TC RB=RC HB=HC ELSEIF (DHA*DHC.GT.0.0 .AND. DHB*DHC.LE.0.0) THEN TA=TC RA=RC HA=HC ELSE GOTO 777 ENDIF 777 ILOOP=ILOOP+1 IF (ILOOP.GT.10000) GOTO 888 IF (DABS(DHAB/HC).GT.1D-7) GOTO 10 T=TC R=G7D07(P,T) S=G3D07(R,T) RETURN 888 T=-1.0E+10 R=-1.0E+10 S=-1.0E+10 RETURN 999 T=-1.0E+20 R=-1.0E+20 S=-1.0E+20 RETURN END C ****************************************** C * TRANSPORT PROPERTIES OF LIQUID AND * C * GASEOUS D2O OVER A WIDE RANGE * C * OF TEMPERATURE AND PRESSURE * C * * C * N.MATSUNAGA AND A.NAGASHIMA * C * * C * JOURNAL OF PHYSICAL AND * C * CHEMICAL REFERENCE DATA, * C * VOL.12 NO.4, PP.933-966, * C * 1983. * C * * C * CODED BY * C * * C * TOMOHIRO HONDA, * C * FUKUOKA UNIVERSITY, * C * FUKUOKA 814-01, JAPAN * C * * C * MARCH 1989 * C ****************************************** C G50 ** VISCOSITY AT RO AND TK FUNCTION G50D07(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA RC,TC,H/358D+00,643.89D+00,55.2651D-06/ DATA B0,B1/ 0.100000D+01, 0.940695D+00/ DATA B2,B3/ 0.578377D+00,-0.202044D+00/ DATA A00,A01,A02,A03,A04,A05 & / 0.4864192D+00, 0.3509007D+00,-0.2847572D+00, & 0.7013759D-01, 0.1641220D-01,-0.1163815D-01/ DATA A10,A11,A12,A13,A14,A15 & /-0.2448372D+00, 0.1315436D+01,-0.1037026D+01, & 0.4660127D+00,-0.2884911D-01,-0.8239587D-02/ DATA A20,A21,A22,A23 & /-0.8702035D+00, 0.1297752D+01,-0.1287846D+01, & 0.2292075D+00/ DATA A30,A31,A33,A34,A36,A40 & / 0.8716056D+00, 0.1353448D+01,-0.4857462D+00, & 0.1607171D+00,-0.3886659D-02,-0.1051126D+01/ DATA A50,A52,A54,A55 & / 0.3458395D+00,-0.2148229D-01,-0.9603846D-02, & 0.4559914D-02/ TR=TK/TC RR=RO/RC IF (TR.GT.0.995D+00 .AND. TR.LT.1.005D+00) THEN IF (RR.GT.0.9D+00 .AND. RR.LT.1.1D+00 ) THEN G50D07=-1.0E+20 RETURN ENDIF ENDIF TI=TC/TK BB=B0+(B1+(B2+B3*TI)*TI)*TI V0=H*DSQRT(TR)/BB TH=TI-1.0D+00 RH=RR-1.0D+00 RH2=RH*RH A0=A00+(A01+(A02+(A03+(A04+A05*RH)*RH)*RH)*RH)*RH A1=A10+(A11+(A12+(A13+(A14+A15*RH)*RH)*RH)*RH)*RH A2=A20+(A21+(A22+A23*RH)*RH)*RH A3=A30+(A31+(A33+(A34+A36*RH2)*RH)*RH2)*RH A4=A40 A5=A50+(A52+(A54+A55*RH)*RH2)*RH2 AA=A0+(A1+(A2+(A3+(A4+A5*TH)*TH)*TH)*TH)*TH VE=DEXP(RR*AA) G50D07=V0*VE RETURN END C G51 ** THERMAL CONDUCTIVITY AT RO AND TK FUNCTION G51D07(RO,TK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT DOUBLE PRECISION (L) DATA TC,RC,LAML/643.89D+00,358D+00,0.742128D-03/ DATA A0,A1,A2,A3,A5 & / 0.100000D+01, 0.373223D+02, 0.225485D+02, & 0.130465D+02,-0.260735D+01/ DATA BE,B0,B1,B2,B3,B4 & /-0.250600D+01,-0.167310D+03, 0.483656D+03, & -0.191039D+03, 0.730358D+02,-0.757467D+01/ DATA C1,C2 / 0.354296D+05, 0.500000D+10/ DATA CT1,CT2 / 0.144847D+00,-0.564493D+01/ DATA CR1,CR2,CR3 & /-0.280000D+01,-0.80738543D-01,-0.179430D+02/ DATA ROR1,D1 / 0.125698D+00,-0.741112D+03/ TR=TK/TC RR=RO/RC IF (TR.GT.0.99D+00 .AND. TR.LT.1.05D+00) THEN IF (RR.GT.0.8D+00 .AND. RR.LT.1.2D+00 ) THEN G51D07=-1.0E+20 RETURN ENDIF ENDIF L0=A0+(A1+(A2+(A3+A5*TR*TR)*TR)*TR)*TR LD=B0*(1.0D+00-DEXP(BE*RR)) LD=LD+(B1+(B2+(B3+B4*RR)*RR)*RR)*RR F1=DEXP((CT1+CT2*TR)*TR) RHB=(RR-1.0D+00)**2 RDB=(RR-ROR1)**2 F2=DEXP(CR1*RHB)+CR2*DEXP(CR3*RDB) TAU=TR/(DABS(TR-1.1D+00)+1.1D+00) F3=1.0D+00+DEXP(60D+00*(TAU-1.0D+00)+20D+00) F4=1.0D+00+DEXP(100D+00*(TAU-1.0D+00)+15D+00) LDC=1.0D+00+F2**2*(C2*F1**4/F3+3.5D+00*F2/F4) LDC=C1*F1*F2*LDC LDL=1D+00-DEXP(-(RR/2.5D+00)**10) LDL=D1*F1**1.2D+00*LDL G51D07=LAML*(L0+LD+LDC+LDL) RETURN END C *** FUNCTION FOR REGION CHECK C G91 FUNC(P) TYPE FUNCTION G91D07(P) DOUBLE PRECISION PCR,PTR,DP,PD INTEGER G91D07 DATA PCR,PTR/216.6D+00,6.601D-03/ PD=DBLE(P) IF (PD.LT.PTR) THEN G91D07=3 ELSEIF (PD.LT.PCR+0.0001D+00) THEN G91D07=0 ELSE G91D07=3 ENDIF IF (G91D07.EQ.0) THEN DP=1.0D+00-PD/PCR IF (DP.LT.1.0D-06) THEN G91D07=1 ENDIF ENDIF RETURN END C G92 FUNC(T) TYPE FUNCTION G92D07(T) DOUBLE PRECISION TTR,TCR,TKCR,TD,TK,DT INTEGER G92D07 DATA TTR,TCR,TKCR/3.8D+00,370.74D+00,643.89D+00/ TD=DBLE(T) IF (TD.LT.TTR) THEN G92D07=3 ELSEIF (TD.LT.TCR+0.0001D+00) THEN G92D07=0 ELSE G92D07=3 ENDIF IF (G92D07.EQ.0) THEN TK=TD+273.15D+00 DT=1.0E+00-TK/TKCR IF (DT.LT.1.0D-06) THEN G92D07=1 ENDIF ENDIF RETURN END C G93 FUNC(P,T) TYPE *** CRITICAL POINT CHECK ROUTINE *** FUNCTION G93D07(P,T) INTEGER G93D07 DATA PCR,TKCR/216.6,643.89/ 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 G93D07=1 RETURN ENDIF ENDIF G93D07=2 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