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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(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 S99CMO(FUN) WTDD=-1.0E+30 RETURN END C C==================================================================== C------------------------------------------------- F1 = AIPPT FUNCTION AIPPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AIPPT'/ CALL S99CMO(FUN) AIPPT=-1.0E+30 RETURN END C------------------------------------------------- F2 = ALAPP FUNCTION ALAPP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALAPP'/ CALL S99CMO(FUN) ALAPP=-1.0E+30 RETURN END C------------------------------------------------- F3 = ALAPT FUNCTION ALAPT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALAPT'/ CALL S99CMO(FUN) ALAPT=-1.0E+30 RETURN END C------------------------------------------------- F4 = ALHP REAL FUNCTION ALHP(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F4CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHP'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F4CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- ALHP=FF RETURN END C------------------------------------------------- F5 = ALHT REAL FUNCTION ALHT(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F5CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHT'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F5CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- ALHT=FF RETURN END C------------------------------------------------- F6 = ALMPD FUNCTION ALMPD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMPD'/ CALL S99CMO(FUN) ALMPD=-1.0E+30 RETURN END C------------------------------------------------- F7 = ALMPDD FUNCTION ALMPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMPDD'/ CALL S99CMO(FUN) ALMPDD=-1.0E+30 RETURN END C------------------------------------------------- F8 = ALMPT FUNCTION ALMPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMPT'/ CALL S99CMO(FUN) ALMPT=-1.0E+30 RETURN END C------------------------------------------------- F9 = ALMTD FUNCTION ALMTD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMTD'/ CALL S99CMO(FUN) ALMTD=-1.0E+30 RETURN END C------------------------------------------------- F10 = ALMTDD FUNCTION ALMTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'ALMTDD'/ CALL S99CMO(FUN) ALMTDD=-1.0E+30 RETURN END C------------------------------------------------- F11 = AMUPD FUNCTION AMUPD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUPD'/ CALL S99CMO(FUN) AMUPD=-1.0E+30 RETURN END C------------------------------------------------- F12 = AMUPDD FUNCTION AMUPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUPDD'/ CALL S99CMO(FUN) AMUPDD=-1.0E+30 RETURN END C------------------------------------------------- F13 = AMUPT FUNCTION AMUPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUPT'/ CALL S99CMO(FUN) AMUPT=-1.0E+30 RETURN END C------------------------------------------------- F14 = AMUTD FUNCTION AMUTD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUTD'/ CALL S99CMO(FUN) AMUTD=-1.0E+30 RETURN END C------------------------------------------------- F15 = AMUTDD FUNCTION AMUTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AMUTDD'/ CALL S99CMO(FUN) AMUTDD=-1.0E+30 RETURN END C------------------------------------------------- F16 = CPPD REAL FUNCTION CPPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F16CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPPD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F16CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPPD=FF RETURN END C------------------------------------------------- F17 = CPPDD FUNCTION CPPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'CPPDD'/ CALL S99CMO(FUN) CPPDD=-1.0E+30 RETURN END C------------------------------------------------- F18 = CPPT FUNCTION CPPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'CPPT'/ CALL S99CMO(FUN) CPPT=-1.0E+30 RETURN END C------------------------------------------------- F19 = CPTD REAL FUNCTION CPTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F19CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CPTD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F19CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- CPTD=FF RETURN END C------------------------------------------------- F20 = CPTDD FUNCTION CPTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'CPTDD'/ CALL S99CMO(FUN) CPTDD=-1.0E+30 RETURN END C------------------------------------------------- F21 = CRP REAL FUNCTION CRP(A) CHARACTER FUN*6,FLUID*8,A*1 REAL T0K,PBAR,FF INTEGER KPA DOUBLE PRECISION F21CMO COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FLUID/'CARBON MONOXIDE'/, FUN/'CRP'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF C--- FUNCTION CALL --- FF = F21CMO(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF(MESS.NE.0) THEN WRITE(6,6010) FUN,FLUID,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A, & ' WHEN A =',A,' ****') FF=-1.0E+20 END IF END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=FF+T0K ELSE IF(A.EQ.'P') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=FF/PBAR END IF CRP=FF RETURN END C------------------------------------------------- F22 = EPSPT FUNCTION EPSPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'EPSPT'/ CALL S99CMO(FUN) EPSPT=-1.0E+30 RETURN END C------------------------------------------------- F89 = FC C************************************************ C FUNCTION FOR FUNDDAMENTAL CONSTANTS C PROPATH VER.10.1, JULY 31, 1996 C USAGE: B=FC(A) C A, B : CHARACTER TYPE VALIABLES C B='28.01' WHEN A='M' C B='296.84' WHEN A='R' C************************************************ REAL FUNCTION FC(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'M') THEN FC=28.01 ELSE IF (A.EQ.'R') THEN FC=296.84 ELSE FC=-1.E+20 IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT FC FOR CARBON MONOXIDE WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F23 = HPD REAL FUNCTION HPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F23CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F23CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPD=FF RETURN END C------------------------------------------------- F24 = HPDD REAL FUNCTION HPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F24CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPDD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F24CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HPDD=FF RETURN END C------------------------------------------------- F25 = HPT FUNCTION HPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'HPT'/ CALL S99CMO(FUN) HPT=-1.0E+30 RETURN END C------------------------------------------------- F26 = HPX FUNCTION HPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'HPX'/ CALL S99CMO(FUN) HPX=-1.0E+30 RETURN END C------------------------------------------------- F27 = HTD REAL FUNCTION HTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F27CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F27CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HTD=FF RETURN END C------------------------------------------------- F28 = HTDD REAL FUNCTION HTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F28CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTDD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F28CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- HTDD=FF RETURN END C------------------------------------------------- F29 = HTX FUNCTION HTX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'HTX'/ CALL S99CMO(FUN) HTX=-1.0E+30 RETURN END C------------------------------------------------- F84 = IDENTF C************************************************ C FUNCTION FOR IDENTIFICATION OF SUBSTANCE C PROPATH VER.12.1, MAY 2, 2001 C USAGE: B=IDENTF(A) C A, B : CHARACTER TYPE VALIABLES C B='CARBON MONOXIDE' WHEN A='S' C B='CO' 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='CARBON MONOXIDE' ELSE IF (A.EQ.'C') THEN IDENTF='CO' ELSE IF (A.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT IDENTF FOR CARBON MONOXIDE WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F30 = PST REAL FUNCTION PST(T) CHARACTER FUN*6 REAL PBAR,T0K,T,FF INTEGER KPA DOUBLE PRECISION F30CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PST'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF TI=T-T0K DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F30CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PST=FF/PBAR RETURN END C------------------------------------------------- F31 = SIGP FUNCTION SIGP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'SIGP'/ CALL S99CMO(FUN) SIGP=-1.0E+30 RETURN END C------------------------------------------------- F32 = SIGT FUNCTION SIGT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'SIGT'/ CALL S99CMO(FUN) SIGT=-1.0E+30 RETURN END C------------------------------------------------- F33 = SPD REAL FUNCTION SPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F33CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F33CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPD=FF RETURN END C------------------------------------------------- F34 = SPDD REAL FUNCTION SPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F34CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPDD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F34CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- SPDD=FF RETURN END C------------------------------------------------- F35 = SPT FUNCTION SPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'SPT'/ CALL S99CMO(FUN) SPT=-1.0E+30 RETURN END C------------------------------------------------- F36 = SPX FUNCTION SPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'SPX'/ CALL S99CMO(FUN) SPX=-1.0E+30 RETURN END C------------------------------------------------- F37 = STD REAL FUNCTION STD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F37CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F37CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- STD=FF RETURN END C------------------------------------------------- F38 = STDD REAL FUNCTION STDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F38CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STDD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F38CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- STDD=FF RETURN END C------------------------------------------------- F39 = STX FUNCTION STX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'STX'/ CALL S99CMO(FUN) STX=-1.0E+30 RETURN END C------------------------------------------------- F40 = TSP REAL FUNCTION TSP(P) CHARACTER FUN*6 REAL PBAR,T0K,P,FF INTEGER KPA DOUBLE PRECISION F40CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TSP'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F40CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TSP=FF+T0K RETURN END C------------------------------------------------- F41 = TRPL REAL FUNCTION TRPL(A) CHARACTER FUN*6,FLUID*8,A*1 REAL T0K,PBAR,FF INTEGER KPA DOUBLE PRECISION F41CMO COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FLUID/'CARBON MONOXIDE'/, FUN/'TRPL'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF C--- FUNCTION CALL --- FF = F41CMO(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF(MESS.NE.0) THEN WRITE(6,6010) FUN,FLUID,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR ',A, & ' WHEN A =',A,' ****') FF=-1.0E+20 END IF END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=FF+T0K ELSE IF(A.EQ.'P') THEN IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=FF/PBAR END IF TRPL=FF RETURN END C------------------------------------------------- F42 = UPD REAL FUNCTION UPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F42CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F42CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPD=FF RETURN END C------------------------------------------------- F43 = UPDD REAL FUNCTION UPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F43CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPDD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F43CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UPDD=FF RETURN END C------------------------------------------------- F44 = UPT FUNCTION UPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'UPT'/ CALL S99CMO(FUN) UPT=-1.0E+30 RETURN END C------------------------------------------------- F45 = UPX FUNCTION UPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'UPX'/ CALL S99CMO(FUN) UPX=-1.0E+30 RETURN END C------------------------------------------------- F46 = UTD REAL FUNCTION UTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F46CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F46CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UTD=FF RETURN END C------------------------------------------------- F47 = UTDD REAL FUNCTION UTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F47CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTDD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F47CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- UTDD=FF RETURN END C------------------------------------------------- F48 = UTX FUNCTION UTX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'UTX'/ CALL S99CMO(FUN) UTX=-1.0E+30 RETURN END C------------------------------------------------- F49 = VPD REAL FUNCTION VPD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F49CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F49CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPD=FF RETURN END C------------------------------------------------- F50 = VPDD REAL FUNCTION VPDD(P) CHARACTER FUN*6 REAL P,FF INTEGER KPA DOUBLE PRECISION F50CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPDD'/ C--- SET OF UNIT --- PI=G98CMO(KPA,P) DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F50CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VPDD=FF RETURN END C------------------------------------------------- F51 = VPT FUNCTION VPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'VPT'/ CALL S99CMO(FUN) VPT=-1.0E+30 RETURN END C------------------------------------------------- F52 = VPX FUNCTION VPX(P,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'VPX'/ CALL S99CMO(FUN) VPX=-1.0E+30 RETURN END C------------------------------------------------- F53 = VTD REAL FUNCTION VTD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F53CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F53CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VTD=FF RETURN END C------------------------------------------------- F54 = VTDD REAL FUNCTION VTDD(T) CHARACTER FUN*6 REAL T,FF INTEGER KPA DOUBLE PRECISION F54CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTDD'/ C--- SET OF UNIT --- TI=G99CMO(KPA,T) DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F54CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- VTDD=FF RETURN END C------------------------------------------------- F55 = VTX FUNCTION VTX(T,X) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'VTX'/ CALL S99CMO(FUN) VTX=-1.0E+30 RETURN END C------------------------------------------------- F56 = XPH FUNCTION XPH(P,H) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPH'/ CALL S99CMO(FUN) XPH=-1.0E+30 RETURN END C------------------------------------------------- F57 = XPS REAL FUNCTION XPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPS'/ CALL S99CMO(FUN) XPS=-1.0E+30 RETURN END C------------------------------------------------- F58 = XPU FUNCTION XPU(P,U) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPU'/ CALL S99CMO(FUN) XPU=-1.0E+30 RETURN END C------------------------------------------------- F59 = XPV FUNCTION XPV(P,V) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XPV'/ CALL S99CMO(FUN) XPV=-1.0E+30 RETURN END C------------------------------------------------- F60 = XTH FUNCTION XTH(T,H) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTH'/ CALL S99CMO(FUN) XTH=-1.0E+30 RETURN END C------------------------------------------------- F61 = XTS FUNCTION XTS(T,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTS'/ CALL S99CMO(FUN) XTS=-1.0E+30 RETURN END C------------------------------------------------- F62 = XTU FUNCTION XTU(T,U) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTU'/ CALL S99CMO(FUN) XTU=-1.0E+30 RETURN END C------------------------------------------------- F63 = XTV FUNCTION XTV(T,V) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'XTV'/ CALL S99CMO(FUN) XTV=-1.0E+30 RETURN END C------------------------------------------------- F64 = TPH FUNCTION TPH(P,H) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPH'/ CALL S99CMO(FUN) TPH=-1.0E+30 RETURN END C------------------------------------------------- F65 = TPS FUNCTION TPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPS'/ CALL S99CMO(FUN) TPS=-1.0E+30 RETURN END C------------------------------------------------- F66 = PLDT FUNCTION PLDT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PLDT'/ CALL S99CMO(FUN) PLDT=-1.0E+30 RETURN END C------------------------------------------------- F67 = TLDP FUNCTION TLDP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TLDP'/ CALL S99CMO(FUN) TLDP=-1.0E+30 RETURN END C------------------------------------------------- F68 = PMLT REAL FUNCTION PMLT(T) CHARACTER FUN*6 REAL PBAR,T0K,T,FF INTEGER KPA DOUBLE PRECISION F68CMO,DBT COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PMLT'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF TI=T-T0K DBT=DBLE(TI) C--- FUNCTION CALL --- FF = F68CMO(DBT) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(2,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PMLT=FF/PBAR RETURN END C------------------------------------------------- F69 = TMLP REAL FUNCTION TMLP(P) CHARACTER FUN*6 REAL PBAR,T0K,P,FF INTEGER KPA DOUBLE PRECISION F69CMO,DBP COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TMLP'/ C--- SET OF UNIT --- IF(KPA.EQ.1) THEN PBAR=1.0 T0K=0.0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0 T0K=273.15 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 T0K=0.0 ELSE PBAR=1.0E-05 T0K=273.15 END IF PI=P*PBAR DBP=DBLE(PI) C--- FUNCTION CALL --- FF = F69CMO(DBP) C--- LEVEL 1 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+10) THEN CALL S97CMO(FUN) FF=-1.0E+10 C--- LEVEL 2 ERROR CHECK & MESSAGE --- ELSE IF(FF.EQ.-1.0E+20) THEN CALL S98CMO(1,P,T,'P','T',FUN) FF=-1.0E+20 END IF C--- SUBSTITUTION OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TMLP=FF+T0K RETURN END C------------------------------------------------- F70 = TPV FUNCTION TPV(P,V) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPV'/ CALL S99CMO(FUN) TPV=-1.0E+30 RETURN END C------------------------------------------------- F71 = HPS FUNCTION HPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'HPS'/ CALL S99CMO(FUN) HPS=-1.0E+30 RETURN END C------------------------------------------------- F72 = PSTD FUNCTION PSTD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PSTD'/ CALL S99CMO(FUN) PSTD=-1.0E+30 RETURN END C------------------------------------------------- F73 = PSTDD FUNCTION PSTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PSTDD'/ CALL S99CMO(FUN) PSTDD=-1.0E+30 RETURN END C------------------------------------------------- F74 = TSPD FUNCTION TSPD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TSPD'/ CALL S99CMO(FUN) TSPD=-1.0E+30 RETURN END C------------------------------------------------- F75 = TSPDD FUNCTION TSPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TSPDD'/ CALL S99CMO(FUN) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F76 = CVPDD FUNCTION CVPDD(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'CVPDD'/ CALL S99CMO(FUN) CVPDD=-1.0E+30 RETURN END C------------------------------------------------- F77= CVPT FUNCTION CVPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'CVPT'/ CALL S99CMO(FUN) CVPT=-1.0E+30 RETURN END C------------------------------------------------- F78 = CVTDD FUNCTION CVTDD(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'CVTDD'/ CALL S99CMO(FUN) CVTDD=-1.0E+30 RETURN END C------------------------------------------------- F79 = UPS FUNCTION UPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'UPS'/ CALL S99CMO(FUN) UPS=-1.0E+30 RETURN END C------------------------------------------------- F80 = VPS FUNCTION VPS(P,S) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'VPS'/ CALL S99CMO(FUN) VPS=-1.0E+30 RETURN END C------------------------------------------------- F81= PRPT FUNCTION PRPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRPT'/ CALL S99CMO(FUN) PRPT=-1.0E+30 RETURN END C------------------------------------------------- F82= AKPT FUNCTION AKPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AKPT'/ CALL S99CMO(FUN) AKPT=-1.0E+30 RETURN END C------------------------------------------------- F83= WPT FUNCTION WPT(P,T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'WPT'/ CALL S99CMO(FUN) WPT=-1.0E+30 RETURN END *------------------------------------------------- F85 = PRPD REAL FUNCTION PRPD(P) REAL P,PI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRPD'/ PI=P CALL S99CMO(FUN) PRPD=-1.0E+30 RETURN END *------------------------------------------------- F86 = PRPDD REAL FUNCTION PRPDD(P) REAL P,PI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRPDD'/ PI=P CALL S99CMO(FUN) PRPDD=-1.0E+30 RETURN END *------------------------------------------------- F87 = PRTD REAL FUNCTION PRTD(T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRTD'/ TI=T CALL S99CMO(FUN) PRTD=-1.0E+30 RETURN END *------------------------------------------------- F88 = PRTDD REAL FUNCTION PRTDD(T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PRTDD'/ TI=T CALL S99CMO(FUN) PRTDD=-1.0E+30 RETURN END *------------------------------------------------- F90= BSPT REAL FUNCTION BSPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BSPT'/ TI=T CALL S99CMO(FUN) BSPT=-1.0E+30 RETURN END *------------------------------------------------- F91= BTPT REAL FUNCTION BTPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BTPT'/ TI=T CALL S99CMO(FUN) BTPT=-1.0E+30 RETURN END *------------------------------------------------- F92= BPPT REAL FUNCTION BPPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BPPT'/ TI=T CALL S99CMO(FUN) BPPT=-1.0E+30 RETURN END *------------------------------------------------- F93= BVPT REAL FUNCTION BVPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'BVPT'/ TI=T CALL S99CMO(FUN) BVPT=-1.0E+30 RETURN END *------------------------------------------------- F94= AJTPT REAL FUNCTION AJTPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'AJTPT'/ TI=T CALL S99CMO(FUN) AJTPT=-1.0E+30 RETURN END *------------------------------------------------- F95= GAMPT REAL FUNCTION GAMPT(P,T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'GAMPT'/ TI=T CALL S99CMO(FUN) GAMPT=-1.0E+30 RETURN END *------------------------------------------------- F96 = GAMPDD REAL FUNCTION GAMPDD(P) REAL P,PI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'GAMPDD'/ PI=P CALL S99CMO(FUN) GAMPDD=-1.0E+30 RETURN END *------------------------------------------------- F97 = GAMTDD REAL FUNCTION GAMTDD(T) REAL T,TI INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'GAMTDD'/ TI=T CALL S99CMO(FUN) GAMTDD=-1.0E+30 RETURN END C------------------------------------------------- F98 = TPSEUP FUNCTION TPSEUP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TPSEUP'/ CALL S99CMO(FUN) TPSEUP=-1.0E+30 RETURN END C------------------------------------------------- F99 = PSBT FUNCTION PSBT(T) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'PSBT'/ CALL S99CMO(FUN) PSBT=-1.0E+30 RETURN END C------------------------------------------------- F100 = TSBP FUNCTION TSBP(P) INTEGER KPA COMMON/UNIT/KPA,MESS CHARACTER FUN*6 DATA FUN/'TSBP'/ CALL S99CMO(FUN) TSBP=-1.0E+30 RETURN END C#################################################################### C C******************************************************************** C* ***************************************** * C* * A PROGRAM PACKAGE OF CARBON MONOXIDE * * C* ***************************************** * C* * C* ***************** ATTENTION ********************** * C* * T : TEMPERATURE, CELSIUS * * C* * H : SPECIFIC ENTHALPY, J/KG * * C* * P : PRESSURE, BAR * * C* * S : SPECIFIC ENTROPY, J/KG/K * * C* * U : SPECIFIC INTERNAL ENERGY, J/KG * * C* * V : SPECIFIC VOLUME, CU.M/KG * * C* ************************************************** * C* * C******************************************************************** C C *** ALHP(P) LATENT HEAT OF VAPORIZATION DOUBLE PRECISION FUNCTION F4CMO(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ DATA WM/28.01D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 QV=F5CMO(T) IF(QV.EQ.-1.0E+20) GO TO 900 F4CMO=QV RETURN 600 F4CMO=-1.0E+20 RETURN 900 F4CMO=-1.0E+20 RETURN END C *** ALHT(T) LATENT HEAT OF VAPORIZATION DOUBLE PRECISION FUNCTION F5CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA WM/28.01D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 CALL S01CMO(TM,PSATF,DPSDT) ALOL=F53CMO(T) IF(ALOL.EQ.-1.0E+20) GO TO 900 DL=ALOL*WM ALG=F54CMO(T) IF(ALG.EQ.-1.0E+20) GO TO 900 DG=ALG*WM QV=100.0D00*TM*DPSDT*(DG-DL) F5CMO=QV*(1.0D03/WM) RETURN 600 F5CMO=-1.0E+20 RETURN 900 F5CMO=-1.0E+20 RETURN END C *** CPPD(P) SPECIFIC HEAT CAPACITY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F16CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ DATA WM/28.01D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 CP=F19CMO(T) IF(CP.EQ.-1.0E+20) GO TO 900 F16CMO=CP RETURN 600 F16CMO=-1.0E+20 RETURN 900 F16CMO=-1.0E+20 RETURN END C *** CPTD(T) SPECIFIC HEAT CAPACITY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F19CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA WM/28.01D00/ DATA DLT/1.6D-06/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 ALO=F53CMO(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) CALL S12CMO(TM,CSATXF) CALL S03CMO(TM,DDSDT,DLIQF) CALL S04CMO(TM,DL,PVTF,DPDT,DPDR) CV = CSATXF + 100.0D00*(TM*DPDT*DDSDT/DL/DL) CP = CV + 100.0D00*(TM*( (DPDT**2)/DPDR )/DL/DL) F19CMO=CP*(1.0D03/WM) RETURN 300 F19CMO=+1.0E+20 RETURN 600 F19CMO=-1.0E+20 RETURN 900 F19CMO=-1.0E+20 RETURN END C *** CRP(A) QUANTITIES AT THE CRITICAL POINT DOUBLE PRECISION FUNCTION F21CMO(A) CHARACTER*1 A,B(5) DATA B/'H','P','S','T','V'/ IF((A.EQ.B(1)).OR.(A.EQ.B(2)).OR.(A.EQ.B(3)).OR. & (A.EQ.B(4)).OR.(A.EQ.B(5))) GO TO 5 GO TO 900 5 IF(A.NE.B(1)) GO TO 10 F21CMO=188.2D03 RETURN 10 IF(A.NE.B(2)) GO TO 20 F21CMO=34.935D00 RETURN 20 IF(A.NE.B(3)) GO TO 30 F21CMO=4.435D03 RETURN 30 IF(A.NE.B(4)) GO TO 40 F21CMO=-140.30D00 RETURN 40 IF(A.NE.B(5)) GO TO 900 F21CMO=3.29D-03 RETURN 900 F21CMO=-1.0E+20 RETURN END C *** HPD(P) SPECIFIC ENTHALPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F23CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 F23CMO=F27CMO(T) RETURN 600 F23CMO=-1.0E+20 RETURN 900 F23CMO=-1.0E+20 RETURN END C *** HPDD(P) SPECIFIC ENTHALPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F24CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 F24CMO=F28CMO(T) RETURN 600 F24CMO=-1.0E+20 RETURN 900 F24CMO=-1.0E+20 RETURN END C *** HTD(T) SPECIFIC ENTHALPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F27CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DIMENSION A(5) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA BET,HTRP,HCRT /0.340D00,0.510D00,5271.879D00/ DATA A / 0.458005588D00,-0.115257944D00,-0.176519530D00, * 0.485799407D00,-0.249044812D00/ DATA WM/28.01D00/ DATA DLT/2.5D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 U = (TCRT-TM)/(TCRT-TTRP) IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 UB = U**BET SM = 0.0D00 DO 7 K=1,5 7 SM = SM + A(K)*U**(K-1) HH = U + (UB - U)*SM H = HCRT + HH*(HTRP-HCRT) F27CMO=H*(1.0D03/WM) RETURN 300 F27CMO=HCRT*(1.0D03/WM) RETURN 600 F27CMO=-1.0E+20 RETURN 900 F27CMO=-1.0E+20 RETURN END C *** HTDD(T) SPECIFIC ENTHALPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F28CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA WM/28.01D00/ DATA DLT/2.5D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 HL=F27CMO(T) IF(HL.EQ.-1.0E+20) GO TO 900 QV=F5CMO(T) IF(QV.EQ.-1.0E+20) GO TO 900 HG = HL + QV F28CMO=HG RETURN 600 F28CMO=-1.0E+20 RETURN 900 F28CMO=-1.0E+20 RETURN END C *** PST(T) SATURATION PRESSURE DOUBLE PRECISION FUNCTION F30CMO(T) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA EPP,TCRT/1.25D00,132.85D00/ DATA TTRP/68.127D000/ DATA PCRT/34.935D00/ DATA TTRPX, TCRTX / 68.1264D00, 132.851D00/ DATA A,B/-7.461267899D00, 16.516128685D00/ DATA C,D,E,F /-12.217914523D00, 9.048182735D00,-2.331639377D00, 1 0.892713142D00/ DATA DLT/2.5D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 X = TM/TCRT X2 = X*X V = 1.0D00 - X IF(DABS((TM-TCRT)/TCRT).LT.DLT) THEN Z = 0.0D00 GO TO 10 END IF Z = V**EPP 10 CONTINUE PL = A/X + B + C*X + D*X2 + E*X*X2 + F*Z PSATF = DEXP(PL) F30CMO=PSATF RETURN 300 F30CMO=PCRT RETURN 600 F30CMO=-1.0E+20 RETURN END C *** SPD(P) SPECIFIC ENTROPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F33CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 F33CMO=F37CMO(T) RETURN 600 F33CMO=-1.0E+20 RETURN 900 F33CMO=-1.0E+20 RETURN END C *** SPDD(P) SPECIFIC ENTROPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F34CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 F34CMO=F38CMO(T) RETURN 600 F34CMO=-1.0E+20 RETURN 900 F34CMO=-1.0E+20 RETURN END C *** STD(T) SPECIFIC ENTROPY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F37CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DIMENSION A(3) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA BET,STRP,SCRT /0.35D00,74.48266D00,124.21963D00/ DATA A / 0.171865846D00,0.135372195D00,0.308872376D00/ DATA WM/28.01D00/ DATA DLT/2.5D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 X = TM/TCRT U = (TCRT-TM)/(TCRT-TTRP) IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 AK = DLOG(TTRP/TCRT) U2 = U*U UB = U**BET SS = UB + A(1)*( DLOG(X)/AK - UB ) * + A(2)*( U - UB ) + A(3)*( U2 - UB ) S = SCRT + SS*(STRP-SCRT) F37CMO=S*(1.0D03/WM) RETURN 300 F37CMO=SCRT*(1.0D03/WM) RETURN 600 F37CMO=-1.0E+20 RETURN 900 F37CMO=-1.0E+20 RETURN END C *** STDD(T) SPECIFIC ENTROPY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F38CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA WM/28.01D00/ DATA DLT/2.5D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 SL=F37CMO(T) IF(SL.EQ.-1.0E+20) GO TO 900 QV=F5CMO(T) IF(QV.EQ.-1.0E+20) GO TO 900 SG = SL + QV/TM F38CMO=SG RETURN 600 F38CMO=-1.0E+20 RETURN 900 F38CMO=-1.0E+20 RETURN END C *** TSP(P) SATURATION TEMPERATURE DOUBLE PRECISION FUNCTION F40CMO(P) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ DATA TCRT/132.85D00/ DATA TTRP/68.127D00/ DATA DLT/2.5D-07/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 IF(DABS((P-PCRT)/PCRT).LT.DLT) GO TO 300 T = 100.0D00 DO 9 J=1,50 T1=T-273.15D00 DPP=F30CMO(T1) IF(DPP.EQ.-1.0E+20) GO TO 900 DP = P - DPP ADP = DABS (DP) CALL S01CMO(T,PSATF,DPSDT) IF(ADP/P-1.0D-7) 10,6,6 6 IF(ADP/DPSDT/T-1.0D-7) 10,7,7 7 T = T + DP/DPSDT IF(T-TCRT) 9,9,8 8 T = TCRT 9 CONTINUE 10 FINDTS = T IF(T.LT.TTRP) FINDTS=TTRP F40CMO=FINDTS-273.15D00 RETURN 300 F40CMO=TCRT-273.15D00 RETURN 600 F40CMO=-1.0E+20 RETURN 900 F40CMO=-1.0E+20 RETURN END C *** TRPL(A) QUANTITIES AT THE TRIPLE POINT DOUBLE PRECISION FUNCTION F41CMO(A) CHARACTER*1 A,B(2) DATA B/'P','T'/ IF (A.EQ.B(1).OR.A.EQ.B(2)) GO TO 5 GO TO 900 5 IF(A.NE.B(1)) GO TO 10 F41CMO=0.1540D00 RETURN 10 IF(A.NE.B(2)) GO TO 900 F41CMO=-205.023D00 RETURN 900 F41CMO=-1.0E+20 RETURN END C *** UPD(P) SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F42CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ DATA WM/28.01D00/ DATA DLT/1.0D-08/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 IF(DABS((P-PTRP)/PTRP).LT.DLT) GO TO 300 ALO=F49CMO(P) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) PS=P H=F23CMO(P) IF(H.EQ.-1.0E+20) GO TO 900 E = H*WM/1.0D03 - 100.0D00*PS/DL F42CMO=E*(1.0D03/WM) RETURN 300 F42CMO= 0.0D00 RETURN 600 F42CMO=-1.0E+20 RETURN 900 F42CMO=-1.0E+20 RETURN END C *** UPDD(P) SPECIFIC INTERNAL ENERGY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F43CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ DATA WM/28.01D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 F43CMO=F47CMO(T) RETURN 600 F43CMO=-1.0E+20 RETURN 900 F43CMO=-1.0E+20 RETURN END C *** UTD(T) SPECIFIC INTERNAL ENERGY OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F46CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA WM/28.01D00/ DATA DLT/1.0D-07/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TTRP)/TTRP).LT.DLT) GO TO 300 ALO=F53CMO(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DL=1.0D00/(ALO*WM) PS=F30CMO(T) IF(PS.EQ.-1.0E+20) GO TO 900 H=F27CMO(T) IF(H.EQ.-1.0E+20) GO TO 900 E = H*WM/1.0D03 - 100.0D00*PS/DL F46CMO=E*(1.0D03/WM) RETURN 300 F46CMO= 0.0D00 RETURN 600 F46CMO=-1.0E+20 RETURN 900 F46CMO=-1.0E+20 RETURN END C *** UTDD(T) SPECIFIC INTERNAL ENERGY OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F47CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA WM/28.01D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 QV=F5CMO(T) IF(QV.EQ.-1.0E+20) GO TO 900 PS=F30CMO(T) IF(PS.EQ.-1.0E+20) GO TO 900 HL=F27CMO(T) IF(HL.EQ.-1.0E+20) GO TO 900 ALO=F54CMO(T) IF(ALO.EQ.-1.0E+20) GO TO 900 DB=1.0D00/ALO EG = HL + QV - 1.0D05*PS/DB F47CMO=EG RETURN 600 F47CMO=-1.0E+20 RETURN 900 F47CMO=-1.0E+20 RETURN END C *** VPD(P) SPECIFIC VOLUME OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F49CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 F49CMO=F53CMO(T) RETURN 600 F49CMO=-1.0E+20 RETURN 900 F49CMO=-1.0E+20 RETURN END C *** VPDD(P) SPECIFIC VOLUME OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F50CMO(P) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA PTRP,PCRT/0.1540D00,34.935D00/ DATA PTRPX,PCRTX/0.15399D00,34.9351D00/ IF(P.LT.PTRPX) GO TO 600 IF(P.GT.PCRTX) GO TO 600 T=F40CMO(P) IF(T.EQ.-1.0E+20) GO TO 900 F50CMO=F54CMO(T) RETURN 600 F50CMO=-1.0E+20 RETURN 900 F50CMO=-1.0E+20 RETURN END C *** VTD(T) SPECIFIC VOLUME OF SATURATED LIQUID DOUBLE PRECISION FUNCTION F53CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DATA DCRT,TCRT /10.85D00,132.85D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA BE / 0.35D00/ DATA A,B,C,D/ 1.85887411D00,0.78620343D00, * -0.34048976D00,0.35040979D00/ DATA DLT/2.5D-07/ DATA WM/28.01D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 X=TM/TCRT U=1.0D00-X UB=U**BE U2=U*U U3=U*U2 Y = A*UB + B*U + C*U2 + D*U3 DLIQF = DCRT*( Y + 1.0D00 ) F53CMO=1.D00/(DLIQF*WM*1.0D-3/1.0D-3) RETURN 300 F53CMO=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F53CMO=-1.0E+20 RETURN END C *** VTDD(T) SPECIFIC VOLUME OF SATURATED VAPOR DOUBLE PRECISION FUNCTION F54CMO(T) IMPLICIT DOUBLE PRECISION(A-H,L-Z) DIMENSION A(5) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA TTRPX,TCRTX /68.1269D00,132.851D00/ DATA BET, GAM, GKK / 0.35D00, 0.70D00, 0.083145D00 / DATA A / -0.7647888D00,-0.5183665D00,2.0294681D00, * -2.0400452D00,1.7965991D00/ DATA DLT/2.5D-07/ DATA WM/28.01D00/ TM=T+273.15D00 IF(TM.LT.TTRPX) GO TO 600 IF(TM.GT.TCRTX) GO TO 600 IF(DABS((TM-TCRT)/TCRT).LT.DLT) GO TO 300 ZCRT = PCRT/DCRT/GKK/TCRT ZN = ZCRT-1.0D00 PC = PCRT P = F30CMO(T) IF(P.EQ.-1.0E+20) GO TO 900 CALL S01CMO(TM,PSATF,DPSDT) PI = P/PC PIT = DPSDT/PC TC = TCRT X = TM/TC X2 = X*X V = 1.0D00-X VB = V**BET VG = V**GAM SM = 0.0D00 DO 7 K=3,5 7 SM= SM + A(K)*V**(K-2) F = 1.0D00 + A(1)*VB + A(2)*VG + SM ZFX = F ZSM1 = ZN*PI*F/X2 Z = 1.0D00 + ZSM1 DGASF = P/TM/Z/GKK F54CMO=1.D00/(DGASF*WM*1.0D-3/1.0D-3) RETURN 300 F54CMO=1.D00/(DCRT*WM*1.0D-3/1.0D-3) RETURN 600 F54CMO=-1.0E+20 RETURN 900 F54CMO=-1.0E+20 RETURN END C *** PMLT(T) PRESSURE ON THE MELTING LINE DOUBLE PRECISION FUNCTION F68CMO(T) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,TTRP/0.1540D00,68.127D00/ C TC -- TMLP(1000 bar) DATA TC/88.317D00/,TL/68.127D00/ DATA TCX/88.3171D00/,TLX/68.1269D00/ DATA A, E / 1690.65D00, 1.79D00 / DATA DLT/1.0D-07/ TM=T+273.15D00 IF(TM.LT.TLX) GO TO 600 IF(TM.GT.TCX) GO TO 600 X = TM/TTRP XE = X**E IF(DABS((TM-TTRP)/TTRP).LT.DLT) XE=1.0D00 PMELTF = PTRP + A*(XE-1.0D00) F68CMO=PMELTF RETURN 600 F68CMO=-1.0E+20 RETURN END C *** TMLP(P) TEMPERATURE ON THE MELTING LINE DOUBLE PRECISION FUNCTION F69CMO(P) IMPLICIT DOUBLE PRECISION (A-H,L-Z) DATA PTRP,TTRP/0.1540D00,68.127D00/ DATA PTRPX/0.15399D00/ DATA A, E / 1690.65D00, 1.79D00 / IF(P.LT.PTRPX.OR.P.GT.1000.001D00) GO TO 600 X = (P-PTRP)/A + 1.0D00 FINDTM = TTRP*X**(1.0D00/E) F69CMO=FINDTM-273.15D00 RETURN 600 F69CMO=-1.0E+20 RETURN END C C******************************************************************** C* ******************************** * C* * FUNCTION FOR SETTING UNITS * * C* ******************************** * C******************************************************************** C REAL FUNCTION G98CMO(KPA,P) REAL P,PBAR IF(KPA.EQ.1) THEN PBAR=1.0E0 ELSE IF(KPA.EQ.2) THEN PBAR=1.0E0 ELSE IF(KPA.EQ.3) THEN PBAR=1.0E-05 ELSE PBAR=1.0E-05 END IF G98CMO=P*PBAR RETURN END REAL FUNCTION G99CMO(KPA,T) REAL T,T0K IF(KPA.EQ.1) THEN T0K=0.0E0 ELSE IF(KPA.EQ.2) THEN T0K=273.15E0 ELSE IF(KPA.EQ.3) THEN T0K=0.0E0 ELSE T0K=273.15E0 END IF G99CMO=T-T0K RETURN END C C#################################################################### C******************************************************************** C* **************** * C* * SUBROUTINE * * C* **************** * C******************************************************************** C C *** DPSDT SUBROUTINE S01CMO(T,PSATF,DPSDT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA EPP,TCRT/1.25D00,132.85D00/ DATA TTRP/68.127D000/ DATA A,B/-7.461267899D00,16.516128685D00/ DATA C,D,E,F /-12.217914523D00,9.048182735D00,-2.331639377D00, 1 0.892713142D00/ DATA DLT/2.5D-07/ X = T/TCRT XI = 1.0D00/X X2 = X*X XIT = -1.0D00/X2 X1T = 1.0D00/TCRT V = 1.0D00 - X IF(DABS((T-TCRT)/TCRT).LT.DLT) THEN Z1 = 0.0D00 Z = 0.0D00 GO TO 10 END IF Z = V**EPP Z1 = -EPP*Z/V 10 CONTINUE PL = A*XI + B + C*X + D*X2 + E*X*X2 + F*Z PL1T = (A*XIT + C + 2.0D00*D*X + 3.0D00*E*X2 + F*Z1)*X1T PSATF = DEXP(PL) DPSDT = PL1T*PSATF RETURN END C C *** DDSDT(V) SUBROUTINE S02CMO(T,DDSDT,ZSAT,ZFX,DGASF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(5) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA BET, GAM, GKK / 0.35D00, 0.70D00, 0.083145D00 / DATA A / -0.7647888D00,-0.5183665D00,2.0294681D00, * -2.0400452D00,1.7965991D00/ DATA DLT/2.5D-07/ DATA WM/28.01D00/ IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 300 ZCRT = PCRT/DCRT/GKK/TCRT ZN = ZCRT-1.0D00 PC = PCRT CALL S01CMO(T,PSATF,DPSDT) P=PSATF PI = P/PC PIT = DPSDT/PC TC = TCRT X = T/TC X2 = X*X V = 1.0D00-X V1 = -1.0D00 VB = V**BET VB1 = V**(BET-1.0D00) VG = V**GAM VG1 = V**(GAM-1.0D00) SM = 0.0D00 DO 7 K=3,5 7 SM= SM + A(K)*V**(K-2) F = 1.0D00 + A(1)*VB + A(2)*VG + SM F1 = -BET*A(1)*VB1/TC - GAM*A(2)*VG1/TC - A(3)/TC * - 2.0D00*A(4)*V/TC * - 3.0D00*A(5)*V*V/TC ZFX = F ZSM1 = ZN*PI*F/X2 Z = 1.0D00 + ZSM1 ZSAT = Z DZDT = (PI*(F1-2.0D00*F/X/TC) + F*PIT)*ZN/X2 DGASF = P/T/Z/GKK DDSDT = (DPSDT - P/T - P*DZDT/Z)/T/Z/GKK RETURN 300 DGASF = DCRT DDSDT = 1.0D+15 RETURN END C C *** DDSDT(L) SUBROUTINE S03CMO(T,DDSDT,DLIQF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA DCRT,TCRT /10.85D00,132.85D00/ DATA BE / 0.35D00/ DATA A,B,C,D/ 1.85887411D00,0.78620343D00, * -0.34048976D00,0.35040979D00/ DATA DLT/2.5D-07/ DATA WM/28.01D00/ IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 300 X=T/TCRT U=1.0D00-X UB=U**BE UB1=U**(BE-1.0D00) U2=U*U U3=U*U2 Y = A*UB + B*U + C*U2 + D*U3 DLIQF = DCRT*( Y + 1.0D00 ) DDSDT = DCRT*( -BE*A*UB1/TCRT - B/TCRT * - 2.0D00*C*U/TCRT - 3.0D00*D*U2/TCRT ) RETURN 300 DLIQF = DCRT DDSDT = 1.0D+15 RETURN END C C *** PVTF,DPDT,DPDR SUBROUTINE S04CMO(T,D,PVTF,DPDT,DPDR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(4) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA DTRP/30.2497D00/ DATA SIG0 / 1.90D00/ DATA A / 0.49072512028D00, 0.16613464874D00, * 0.03757657750D00, 0.13810146746D00/ DATA R/0.083145D00/ SIG=D/DCRT SIGT=DTRP/DCRT SF = SIG**3 - (SIGT+SIG0+1.0D00)*SIG**2 * + (SIGT*SIG0+SIGT+SIG0)*SIG - SIGT*SIG0 SF1T = 0.0D00 SF1R = 3.0D00*SIG**2/DCRT - 2.0D00*(SIGT+SIG0+1.0D00)*SIG/DCRT * + (SIGT*SIG0+SIGT+SIG0)/DCRT CALL S01CMO(T,PSATF,DPSDT) CALL S06CMO(D,TSATF,DTSDR) CALL S08CMO(T,D,F1,F1T,F1D) CALL S09CMO(T,D,F2,F2T,F2D) CALL S10CMO(T,D,F3,F3T,F3D) CALL S11CMO(T,D,F4,F4T,F4D) FF = A(1)*F1 + A(2)*SIG*F2 + A(3)*SIG*SIG*F3 + A(4)*SF*F4 FF1T = A(1)*F1T + A(2)*SIG*F2T + A(3)*SIG*SIG*F3T + A(4)*SF*F4T FF1R = A(1)*F1D + A(2)*(SIG*F2D+SIG/D*F2) * + A(3)*(SIG*SIG*F3D+2.0D00*SIG*F3/DCRT) * + A(4)*(SF*F4D+SF1R*F4) PVTF = PSATF + D*R*(T-TSATF) + SIG*(D*R*TCRT)*FF DPDT = D*R + SIG*(D*R*TCRT)*FF1T DPDD = DPSDT*DTSDR + (R*T) - (R*TSATF + D*R*DTSDR) * + (2.0D00*SIG*R*TCRT*FF + SIG*D*R*TCRT*FF1R) DPDR = DPDD/DTRP RETURN END C C *** TSATF SUBROUTINE S06CMO(DEN,TSATF,DTSDR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA DTRP/30.2497D00/ DATA Q, FN / 2.0D00, 6.3890561D00 / DATA WM/28.01D00/ C NOTE, FN = EXP(Q) - 1.0. CALL S02CMO(TTRP,DDSDT,ZSAT,ZFX,DGASF) DGAT = DGASF D=DEN S=D/DCRT YN=TCRT/TTRP-1.0D00 IF(DEN-DCRT) 3,30,4 3 ST=DGAT/DCRT F=DLOG(S)/DLOG(ST)*((1.0D00-S)/(1.0D00-ST))**2 GO TO 5 4 ST=DTRP/DCRT U=((S-1.0D00)/(ST-1.0D00))**3 F=(DEXP(Q*U)-1.0D00)/FN 5 TT = TCRT/(1.0D00 + YN*F) DO 15 J=1,100 IF(DEN-DCRT) 7,30,8 7 CALL S02CMO(TT,DDSDT,ZSAT,ZFX,DGASF) DD = D - DGASF GO TO 9 8 CALL S03CMO(TT,DDSDT,DLIQF) DD = D - DLIQF 9 IF(DABS(DD/D).LT.1.0D-7) GO TO 16 10 DT = DD/DDSDT IF(DABS(DT/TT).LT.1.0D-7) GO TO 16 11 TT = TT + DT IF(TT) 12,12,13 12 TT = TTRP GO TO 15 13 IF(TT.LT.TCRT) GO TO 15 14 TT = TCRT - 0.10D00 15 CONTINUE 16 TSATF = TT DTSDR = DTRP/DDSDT RETURN 30 TSATF = TCRT DTSDR = 0.0D00 RETURN END C C *** THETAF SUBROUTINE S07CMO(DEN,THETAF,DTHDR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA DTRP/30.2497D00/ DATA AL/1.0D00/ CALL S06CMO(DEN,TSATF,DTSDR) TSAT=TSATF S = DEN/DCRT DSDR = DTRP/DCRT C = DSDR-1.0D00 Q = (S-1.0D00)/C Q2 = Q*Q U = AL*Q*Q2 U1 = AL*3.0D00*Q2*DSDR/C IF(Q) 5,9,4 4 U = -U U1 = -U1 5 XP = DEXP(U) THETAF = TSAT*XP 6 DTHDR = (TSAT*U1 + DTSDR)*XP RETURN 9 THETAF = TCRT DTHDR = 0.0D00 RETURN END C C *** F1 SUBROUTINE S08CMO(T,D,F1,F1T,F1D) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA DTRP/30.2497D00/ CALL S06CMO(D,TSATF,DTSDR) TS = TSATF TC = TCRT X = T/TC X1 = 1.0D00/TC XS = TS/TC XS1 = DTSDR/TC F1 = X - XS F1T = X1 F1D = -XS1 RETURN END C C *** F2 SUBROUTINE S09CMO(T,D,F2,F2T,F2D) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA DTRP/30.2497D00/ DATA EP/0.5D00/ B=(1.0D00-EP)+(1.0D00-EP)**0.5D00 CALL S06CMO(D,TSATF,DTSDR) TS = TSATF TC = TCRT X = T/TC XS = TS/TC F2 = (X**EP)*EXP( B*(1.0D00-TS/T) ) - (XS**EP) F2T = (X**EP)*(-(-(B*TS)*DEXP( B - B*TS/T )/T/T )) * + EP*(X**(EP-1.0D00))/TC*DEXP( B*(1.0D00-TS/T) ) F2D = (X**EP)*( -B*DTSDR/T )*DEXP( B - B*TS/T ) * - EP*(XS**(EP-1.0D00))*DTSDR/TC RETURN END C C *** F3 SUBROUTINE S10CMO(T,D,F3,F3T,F3D) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA DTRP/30.2497D00/ CALL S06CMO(D,TSATF,DTSDR) TS = TSATF F3 = DEXP( 2.0D00 - 2.0D00*TS/T ) - 1.0D00 F3T =-(-(2.0D00*TS)*DEXP( 2.0D00 - 2.0D00*TS/T )/T/T ) F3D = ( -2.0D00*DTSDR/T )*DEXP( 2.0D00 - 2.0D00*TS/T ) RETURN END C C *** F4 SUBROUTINE S11CMO(T,D,F4,F4T,F4D) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA DCRT,TTRP,TCRT/10.85D00,68.127D00,132.85D00/ DATA PCRT/34.935D00/ DATA DTRP/30.2497D00/ DATA YTA/1.10D00/ CALL S06CMO(D,TSATF,DTSDR) CALL S07CMO(D,THETAF,DTHDR) TS = TSATF TH = THETAF TC = TCRT W = 1.0D00 - TH/T IF(W.LT.0.0D00) GO TO 30 W1T = -(-TH/T/T) W1R = -DTHDR/T WI1T = YTA*(W**(YTA-1.0D00))*(-(-TH/T/T)) WI1R = YTA*(W**(YTA-1.0D00))*(-(DTHDR/T)) WS = 1.0D00 - TH/TS WS1T = 0.0D00 WS1R =-(DTHDR*TS-TH*DTSDR)/TS/TS WSI1T = 0.0D00 WSI1R = YTA*(WS**(YTA-1.0D00))*(-(DTHDR*TS-TH*DTSDR)/TS/TS) P = 1.0D00 - ( W - (W**YTA)/YTA )/(1.0D00 - 1.0D00/YTA) P1T = -(W1T - WI1T/YTA)/(1.0D00 - 1.0D00/YTA) P1R = -(W1R - WI1R/YTA)/(1.0D00 - 1.0D00/YTA) PS = 1.0D00 - ( WS - (WS**YTA)/YTA )/(1.0D00 - 1.0D00/YTA) PS1T = 0.0D00 PS1R = -(WS1R - WSI1R/YTA)/(1.0D00 - 1.0D00/YTA) F4 = P/PS - 1.0D00 F4T = P1T/PS F4D = (P1R*PS-P*PS1R)/PS/PS RETURN 30 F4 = 0.0D00 F4T = 0.0D00 F4D = 0.0D00 RETURN END C C *** CSATXF SUBROUTINE S12CMO(T,CSATXF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(3) DATA TTRP,TCRT /68.127D00,132.85D00/ DATA BET,C,STRP,SCRT/0.35D00,0.660D00,74.48266D00,124.21963D00/ DATA A / 0.171865846D00,0.135372195D00,0.308872376D00/ DATA WM/28.01D00/ DATA DLT/2.5D-07/ X = T/TCRT U = (TCRT-T)/(TCRT-TTRP) IF(DABS((T-TCRT)/TCRT).LT.DLT) GO TO 300 UC = U**C SN = STRP-SCRT A4 = 1.0D00 - A(1) - A(2) - A(3) SUM = A(2) + 2.0D00*A(3)*U + A4*BET/UC AK = DLOG(TTRP/TCRT) DUDX = -TCRT/(TCRT-TTRP) CSATXF = SN*( A(1)/AK + X*SUM*DUDX) RETURN 300 CSATXF = 0.0D00 RETURN END C C******************************************************************** C* ********************************** * C* * SUBROUTINE FOR ERROR MESSAGE * * C* ********************************** * C******************************************************************** C C *** LEVEL 1 ERROR MESSAGE *** SUBROUTINE S97CMO(FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** NO CONVERGENCE AT '//FUN//' FOR CARBON MONOXIDE ****' WRITE(6,*) MSG END IF RETURN END C *** LEVEL 2 ERROR MESSAGE *** SUBROUTINE S98CMO(IPT,P,T,N1,N2,FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,N1*1,N2*1 IF(MESS.NE.0) THEN IF (IPT.EQ.1) THEN C --- FUN(P) TYPE WRITE(6,6010) FUN,P 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR CARBON MONOXIDE', & ' WHEN P =',1PE14.7,' ****') C --- FUN(T) TYPE ELSE IF (IPT.EQ.2) THEN WRITE(6,6020) FUN,T 6020 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR CARBON MONOXIDE', & ' WHEN T =',1PE14.7,' ****') C --- FUN(P,T) TYPE ELSE WRITE(6,6030) FUN,N1,P,N2,T 6030 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR CARBON MONOXIDE', &' WHEN ',A1,' =',1PE14.7,' AND ',A1,' =',1PE14.7,' ****') END IF END IF RETURN END C *** LEVEL 3 ERROR MESSAGE *** SUBROUTINE S99CMO(FUN) COMMON/UNIT/KPA,MESS CHARACTER FUN*6,MSG*125 IF(MESS.NE.0) THEN MSG='**** FUNCTION '//FUN//' UNAVAILABLE FOR CARBON *MONOXIDE ****' WRITE(6,100) MSG 100 FORMAT(1H ,5X,A) END IF RETURN END REAL FUNCTION T90(T) * Conversion of temperature scal from IPTS-68 to ITS-90 * Range -200C<=T68<=630C anf T68>=1064 REAL T68,T0K REAL*8 CA(8) INTEGER KPA,MESS COMMON/UNIT/KPA,MESS DATA CA/-0.14542, -0.26722, 1.06471, 1.131286, -4.25835, + -1.59924, 7.29176, -3.52573/ IF((KPA.EQ.1).OR.(KPA.EQ.3)) THEN T0K=0.0 ELSE T0K=273.15 END IF T68=T-T0K * Check of argument range IF((-200.0.LE.T68).AND.(T68.LE.630.0)) THEN RT68=T68/630.0 TEMP=T68+RT68*(CA(1)+RT68*(CA(2)+RT68*(CA(3)+RT68*(CA(4) + +RT68*(CA(5)+RT68*(CA(6)+RT68*(CA(7)+RT68*CA(8)))))))) ELSE IF((1064.0.LE.T68).AND.(T68.LE.3000.0)) THEN TEMP=T68-0.25*(T68+273.15)*(T68+273.15)/1337.33/1337.33 ELSE IF(MESS.NE.0) WRITE(6,6020) T 6020 FORMAT(1H ,5X,'**** OUT OF RANGE AT T90', & ' WHEN T68 =',1PE14.7,' ****') T90=-1.0E+20 RETURN END IF T90=TEMP+T0K RETURN END REAL FUNCTION T68(T) * Conversion of temperature scal from ITS-90 to IPTS-68 * Range -200C<=T68<=630C anf T68>=1064 T1=T90(T) T2=T ITER=0 DT=T-T1 1000 CONTINUE ITER=ITER+1 IF(ITER.GE.10000) THEN WRITE(6,*) ' ITERATION EXCEEDED MAXIMUM ' T68=-1.0E+10 RETURN END IF T2=T2+DT T1=T90(T2) DT=T-T1 IF(ABS(DT).GE.1.0E-4) GOTO 1000 T68=T2 RETURN END * Subroutine Program Specifying KPA and MESS * MS-FORTRAN and MS-C Mixed Langage Programing * SUBROUTINE KPAMES(KPAC,MESSC) COMMON/UNIT/KPA,MESS INTEGER KPAC INTEGER MESSC KPA=KPAC MESS=MESSC RETURN END