C-------------------------------------- H2OITS-90 VER.1 C--- PROPATH 10.1 ****** WATER ****** 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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(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 SE3A03(FUN) WTDD=-1.0E+30 RETURN END C C==================================================================== C------------------------------------------------- F1 = AIPPT FUNCTION AIPPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='AIPPT' IF (MESS.NE.0) CALL SE3A03(FUN) AIPPT=-1.0E+30 RETURN END C------------------------------------------------- F2 = ALAPP FUNCTION ALAPP(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALAPP'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F2A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- ALAPP=SNGL(FF) RETURN END C------------------------------------------------- F3 = ALAPT FUNCTION ALAPT(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALAPT'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F3A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- ALAPT=SNGL(FF) RETURN END C------------------------------------------------- F4 = ALHP FUNCTION ALHP(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHP'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F4A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- ALHP=SNGL(FF) RETURN END C------------------------------------------------- F5 = ALHT FUNCTION ALHT(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'ALHT'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F5A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- ALHT=SNGL(FF) RETURN END C------------------------------------------------- F6 = ALMPD FUNCTION ALMPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='ALMPD' IF (MESS.NE.0) CALL SE3A03(FUN) ALMPD=-1.0E+30 RETURN END C------------------------------------------------- F7 = ALMPDD FUNCTION ALMPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='ALMPDD' IF (MESS.NE.0) CALL SE3A03(FUN) ALMPDD=-1.0E+30 RETURN END C------------------------------------------------- F8 = ALMPT FUNCTION ALMPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='ALMPT' IF (MESS.NE.0) CALL SE3A03(FUN) ALMPT=-1.0E+30 RETURN END C------------------------------------------------- F9 = ALMTD FUNCTION ALMTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='ALMTD' IF (MESS.NE.0) CALL SE3A03(FUN) ALMTD=-1.0E+30 RETURN END C------------------------------------------------- F10 = ALMTDD FUNCTION ALMTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='ALMTDD' IF (MESS.NE.0) CALL SE3A03(FUN) ALMTDD=-1.0E+30 RETURN END C------------------------------------------------- F11 = AMUPD FUNCTION AMUPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='AMUPD' IF (MESS.NE.0) CALL SE3A03(FUN) AMUPD=-1.0E+30 RETURN END C------------------------------------------------- F12 = AMUPDD FUNCTION AMUPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='AMUPDD' IF (MESS.NE.0) CALL SE3A03(FUN) AMUPDD=-1.0E+30 RETURN END C------------------------------------------------- F13 = AMUPT FUNCTION AMUPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='AMUPT' IF (MESS.NE.0) CALL SE3A03(FUN) AMUPT=-1.0E+30 RETURN END C------------------------------------------------- F14 = AMUTD FUNCTION AMUTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='AMUTD' IF (MESS.NE.0) CALL SE3A03(FUN) AMUTD=-1.0E+30 RETURN END C------------------------------------------------- F15 = AMUTDD FUNCTION AMUTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='AMUTDD' IF (MESS.NE.0) CALL SE3A03(FUN) AMUTDD=-1.0E+30 RETURN END C------------------------------------------------- F16 = CPPD FUNCTION CPPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='CPPD' IF (MESS.NE.0) CALL SE3A03(FUN) CPPD=-1.0E+30 RETURN END C------------------------------------------------- F17 = CPPDD FUNCTION CPPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='CPPDD' IF (MESS.NE.0) CALL SE3A03(FUN) CPPDD=-1.0E+30 RETURN END C------------------------------------------------- F18 = CPPT FUNCTION CPPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='CPPT' IF (MESS.NE.0) CALL SE3A03(FUN) CPPT=-1.0E+30 RETURN END C------------------------------------------------- F19 = CPTD FUNCTION CPTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='CPTD' IF (MESS.NE.0) CALL SE3A03(FUN) CPTD=-1.0E+30 RETURN END C------------------------------------------------- F20 = CPTDD FUNCTION CPTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='CPTDD' IF (MESS.NE.0) CALL SE3A03(FUN) CPTDD=-1.0E+30 RETURN END C------------------------------------------------- F21 = CRP FUNCTION CRP(A) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6,A*1 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'CRP'/ C--- FUNCTION CALL --- FF=F21A03(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF(MESS.NE.0) WRITE(6,6010) FUN,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR WATER', & ' WHEN A =',A,' ****') FF=-1.0E+20 END IF C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN T0K=-DBLE(G99A03(KPA,0.0)) IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=SNGL(FF)+T0K ELSE IF(A.EQ.'P') THEN PBAR=G98A03(KPA,1.0) IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=SNGL(FF)/PBAR END IF CRP=SNGL(FF) RETURN END C------------------------------------------------- F22 = EPSPT FUNCTION EPSPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='EPSPT' IF (MESS.NE.0) CALL SE3A03(FUN) EPSPT=-1.0E+30 RETURN END C------------------------------------------------- F89 = FC C************************************************ C FUNCTION FOR FUNDDAMENTAL CONSTANTS C PROPATH VER.8.1, MAY 12, 1993 C USAGE: B=FC(A) C A, B : CHARACTER TYPE VALIABLES C B='18.0153' WHEN A='M' C B='461.51' WHEN A='R' C************************************************ REAL FUNCTION FC(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'M') THEN FC=18.0153 ELSE IF (A.EQ.'R') THEN FC=461.51 ELSE FC=-1.E+20 IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT FC FOR WATER(IFC 1967) WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F23 = HPD FUNCTION HPD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F23A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- HPD=SNGL(FF) RETURN END C------------------------------------------------- F24 = HPDD FUNCTION HPDD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPDD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F24A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- HPDD=SNGL(FF) RETURN END C------------------------------------------------- F25 = HPT FUNCTION HPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='HPT' IF (MESS.NE.0) CALL SE3A03(FUN) HPT=-1.0E+30 RETURN END C------------------------------------------------- F26 = HPX FUNCTION HPX(P,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HPX'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F26A03(DP,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DX,'P','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- HPX=SNGL(FF) RETURN END C------------------------------------------------- F27 = HTD FUNCTION HTD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F27A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- HTD=SNGL(FF) RETURN END C------------------------------------------------- F28 = HTDD FUNCTION HTDD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTDD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F28A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- HTDD=SNGL(FF) RETURN END C------------------------------------------------- F29 = HTX FUNCTION HTX(T,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'HTX'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F29A03(DT,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DX,'T','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- HTX=SNGL(FF) RETURN END C------------------------------------------------- F84 = IDENTF C************************************************ C FUNCTION FOR IDENTIFICATION OF SUBSTANCE C PROPATH VER.12.1, MAY 2, 2001 C USAGE: B=IDENTF(A) C A, B : CHARACTER TYPE VALIABLES C B='WATER(IFC 1967)' WHEN A='S' C B='H2O' WHEN A='C' C B='12.1' WHEN A='V' C************************************************ CHARACTER*20 FUNCTION IDENTF(A) CHARACTER A*1,MSG*120 COMMON/UNIT/KPA,MESS IF (A.EQ.'S') THEN IDENTF='WATER(IFC 1967)' ELSE IF (A.EQ.'C') THEN IDENTF='H2O' ELSE IF (A.EQ.'V') THEN IDENTF='12.1' ELSE IDENTF='????????????????????' IF (MESS.NE.0) THEN MSG='**** OUT OF RANGE AT IDENTF FOR WATER WHEN A=''' & //A//''' ****' WRITE(6,'(1H ,A)') MSG END IF END IF RETURN END C------------------------------------------------- F30 = PST FUNCTION PST(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PST'/ C--- SET OF UNIT --- PBAR=G98A03(KPA,1.0) DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F30A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PST=SNGL(FF)/PBAR RETURN END C------------------------------------------------- F31 = SIGP FUNCTION SIGP(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SIGP'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F31A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- SIGP=SNGL(FF) RETURN END C------------------------------------------------- F32 = SIGT FUNCTION SIGT(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SIGT'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F32A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- SIGT=SNGL(FF) RETURN END C------------------------------------------------- F33 = SPD FUNCTION SPD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F33A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- SPD=SNGL(FF) RETURN END C------------------------------------------------- F34 = SPDD FUNCTION SPDD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPDD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F34A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- SPDD=SNGL(FF) RETURN END C------------------------------------------------- F35 = SPT FUNCTION SPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='SPT' IF (MESS.NE.0) CALL SE3A03(FUN) SPT=-1.0E+30 RETURN END C------------------------------------------------- F36 = SPX FUNCTION SPX(P,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'SPX'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F36A03(DP,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DX,'P','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- SPX=SNGL(FF) RETURN END C------------------------------------------------- F37 = STD FUNCTION STD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F37A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- STD=SNGL(FF) RETURN END C------------------------------------------------- F38 = STDD FUNCTION STDD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STDD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F38A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- STDD=SNGL(FF) RETURN END C------------------------------------------------- F39 = STX FUNCTION STX(T,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'STX'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F39A03(DT,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DX,'T','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- STX=SNGL(FF) RETURN END FUNCTION TPSEUP(P) CHARACTER FUN*6 COMMON /UNIT/KPA,MESS FUN='TPSEUP' X1=P FUN='TPSEUP' IF (MESS.NE.0) CALL SE3A03(FUN) TPSEUP=-1.0E+30 RETURN END C------------------------------------------------- F40 = TSP FUNCTION TSP(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TSP'/ C--- SET OF UNIT --- T0K=DBLE(G99A03(KPA,0.0)) DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F40A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TSP=SNGL(FF)-T0K RETURN END C------------------------------------------------- F41 = TRPL FUNCTION TRPL(A) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6,A*1 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TRPL'/ C--- FUNCTION CALL --- FF=F41A03(A) C--- LEVEL 2 ERROR CHECK & MESSAGE --- IF(FF.EQ.-1.0E+20) THEN IF(MESS.NE.0) WRITE(6,6010) FUN,A 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR WATER', & ' WHEN A =',A,' ****') FF=-1.0E+20 END IF C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF(A.EQ.'T') THEN T0K=-DBLE(G99A03(KPA,0.0)) IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 FF=SNGL(FF)+T0K ELSE IF(A.EQ.'P') THEN PBAR=G98A03(KPA,1.0) IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 FF=SNGL(FF)/PBAR END IF TRPL=SNGL(FF) RETURN END C------------------------------------------------- F42 = UPD FUNCTION UPD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F42A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- UPD=SNGL(FF) RETURN END C------------------------------------------------- F43 = UPDD FUNCTION UPDD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPDD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F43A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- UPDD=SNGL(FF) RETURN END C------------------------------------------------- F44 = UPT FUNCTION UPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='UPT' IF (MESS.NE.0) CALL SE3A03(FUN) UPT=-1.0E+30 RETURN END C------------------------------------------------- F45 = UPX FUNCTION UPX(P,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UPX'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F45A03(DP,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DX,'P','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- UPX=SNGL(FF) RETURN END C------------------------------------------------- F46 = UTD FUNCTION UTD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F46A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- UTD=SNGL(FF) RETURN END C------------------------------------------------- F47 = UTDD FUNCTION UTDD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTDD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F47A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- UTDD=SNGL(FF) RETURN END C------------------------------------------------- F48 = UTX FUNCTION UTX(T,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'UTX'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F48A03(DT,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DX,'T','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- UTX=SNGL(FF) RETURN END C------------------------------------------------- F49 = VPD FUNCTION VPD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F49A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- VPD=SNGL(FF) RETURN END C------------------------------------------------- F50 = VPDD FUNCTION VPDD(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPDD'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F50A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- VPDD=SNGL(FF) RETURN END C------------------------------------------------- F51 = VPT FUNCTION VPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='VPT' IF (MESS.NE.0) CALL SE3A03(FUN) VPT=-1.0E+30 RETURN END C------------------------------------------------- F52 = VPX FUNCTION VPX(P,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VPX'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F52A03(DP,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DX,'P','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- VPX=SNGL(FF) RETURN END C------------------------------------------------- F53 = VTD FUNCTION VTD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F53A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- VTD=SNGL(FF) RETURN END C------------------------------------------------- F54 = VTDD FUNCTION VTDD(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTDD'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F54A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- VTDD=SNGL(FF) RETURN END C------------------------------------------------- F55 = VTX FUNCTION VTX(T,X) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'VTX'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DX=DBLE(X) C--- FUNCTION CALL --- FF=F55A03(DT,DX) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DX,'T','X',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- VTX=SNGL(FF) RETURN END C------------------------------------------------- F56 = XPH FUNCTION XPH(P,H) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPH'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DH=DBLE(H) C--- FUNCTION CALL --- FF=F56A03(DP,DH) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DH,'P','H',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XPH=SNGL(FF) RETURN END C------------------------------------------------- F57 = XPS FUNCTION XPS(P,S) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPS'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DS=DBLE(S) C--- FUNCTION CALL --- FF=F57A03(DP,DS) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DS,'P','S',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XPS=SNGL(FF) RETURN END C------------------------------------------------- F58 = XPU FUNCTION XPU(P,U) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPU'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DU=DBLE(U) C--- FUNCTION CALL --- FF=F58A03(DP,DU) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DU,'P','U',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XPU=SNGL(FF) RETURN END C------------------------------------------------- F59 = XPV FUNCTION XPV(P,V) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XPV'/ C--- SET OF UNIT --- DP=DBLE(G98A03(KPA,P)) DV=DBLE(V) C--- FUNCTION CALL --- FF=F59A03(DP,DV) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DP,DV,'P','V',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XPV=SNGL(FF) RETURN END C------------------------------------------------- F60 = XTH FUNCTION XTH(T,H) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTH'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DH=DBLE(H) C--- FUNCTION CALL --- FF=F60A03(DT,DH) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DH,'T','H',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XTH=SNGL(FF) RETURN END C------------------------------------------------- F61 = XTS FUNCTION XTS(T,S) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTS'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DS=DBLE(S) C--- FUNCTION CALL --- FF=F61A03(DT,DS) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DS,'T','S',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XTS=SNGL(FF) RETURN END C------------------------------------------------- F62 = XTU FUNCTION XTU(T,U) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTU'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DU=DBLE(U) C--- FUNCTION CALL --- FF=F62A03(DT,DU) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DU,'T','U',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XTU=SNGL(FF) RETURN END C------------------------------------------------- F63 = XTV FUNCTION XTV(T,V) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'XTV'/ C--- SET OF UNIT --- DT=DBLE(G99A03(KPA,T)) DV=DBLE(V) C--- FUNCTION CALL --- FF=F63A03(DT,DV) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,3,DT,DV,'T','V',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- XTV=SNGL(FF) RETURN END C------------------------------------------------- F64 = TPH FUNCTION TPH(P,H) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=H FUN='TPH' IF (MESS.NE.0) CALL SE3A03(FUN) TPH=-1.0E+30 RETURN END C------------------------------------------------- F65 = TPS FUNCTION TPS(P,S) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=S FUN='TPS' IF (MESS.NE.0) CALL SE3A03(FUN) TPS=-1.0E+30 RETURN END C------------------------------------------------- F66 = PLDT FUNCTION PLDT(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='PLDT' IF (MESS.NE.0) CALL SE3A03(FUN) PLDT=-1.0E+30 RETURN END C------------------------------------------------- F67 = TLDP FUNCTION TLDP(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='TLDP' IF (MESS.NE.0) CALL SE3A03(FUN) TLDP=-1.0E+30 RETURN END C------------------------------------------------- F68 = PMLT FUNCTION PMLT(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PMLT'/ C--- SET OF UNIT --- PBAR=G98A03(KPA,1.0) DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F68A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PMLT=SNGL(FF)/PBAR RETURN END C------------------------------------------------- F69 = TMLP FUNCTION TMLP(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TMLP'/ C--- SET OF UNIT --- T0K=DBLE(G99A03(KPA,0.0)) DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F69A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TMLP=SNGL(FF)-T0K RETURN END C------------------------------------------------- F70 = TPV FUNCTION TPV(P,V) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=V FUN='TPV' IF (MESS.NE.0) CALL SE3A03(FUN) TPV=-1.0E+30 RETURN END C------------------------------------------------- F71 = HPS FUNCTION HPS(P,S) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS X1=P X1=S FUN='HPS' IF (MESS.NE.0) CALL SE3A03(FUN) HPS=-1.0E+30 RETURN END C------------------------------------------------- F72 = PSTD FUNCTION PSTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='PSTD' IF (MESS.NE.0) CALL SE3A03(FUN) PSTD=-1.0E+30 RETURN END C------------------------------------------------- F73 = PSTDD FUNCTION PSTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='PSTDD' IF (MESS.NE.0) CALL SE3A03(FUN) PSTDD=-1.0E+30 RETURN END C------------------------------------------------- F74 = TSPD FUNCTION TSPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='TSPD' IF (MESS.NE.0) CALL SE3A03(FUN) TSPD=-1.0E+30 RETURN END C------------------------------------------------- F75 = TSPDD FUNCTION TSPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='TSPDD' IF (MESS.NE.0) CALL SE3A03(FUN) TSPDD=-1.0E+30 RETURN END C------------------------------------------------- F76 = CVPDD FUNCTION CVPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='CVPDD' IF (MESS.NE.0) CALL SE3A03(FUN) CVPDD=-1.0E+30 RETURN END C------------------------------------------------- F77 = CVPT FUNCTION CVPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='CVPT' IF (MESS.NE.0) CALL SE3A03(FUN) CVPT=-1.0E+30 RETURN END C------------------------------------------------- F78 = CVTDD FUNCTION CVTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='CVTDD' IF (MESS.NE.0) CALL SE3A03(FUN) CVTDD=-1.0E+30 RETURN END C------------------------------------------------- F79 = UPS FUNCTION UPS(P,S) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=S FUN='UPS' IF (MESS.NE.0) CALL SE3A03(FUN) UPS=-1.0E+30 RETURN END C------------------------------------------------- F80 = VPS FUNCTION VPS(P,S) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=S FUN='VPS' IF (MESS.NE.0) CALL SE3A03(FUN) VPS=-1.0E+30 RETURN END C------------------------------------------------- F81 = PRPT FUNCTION PRPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='PRPT' IF (MESS.NE.0) CALL SE3A03(FUN) PRPT=-1.0E+30 RETURN END C------------------------------------------------- F82 = AKPT FUNCTION AKPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='AKPT' IF (MESS.NE.0) CALL SE3A03(FUN) AKPT=-1.0E+30 RETURN END C------------------------------------------------- F83 = WPT FUNCTION WPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P X1=T FUN='WPT' IF (MESS.NE.0) CALL SE3A03(FUN) WPT=-1.0E+30 RETURN END C------------------------------------------------- F85 = PRPD FUNCTION PRPD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='PRPD' IF (MESS.NE.0) CALL SE3A03(FUN) PRPD=-1.0E+30 RETURN END C------------------------------------------------- F86 = PRPDD FUNCTION PRPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='PRPDD' IF (MESS.NE.0) CALL SE3A03(FUN) PRPDD=-1.0E+30 RETURN END C------------------------------------------------- F87 = PRTD FUNCTION PRTD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='PRTD' IF (MESS.NE.0) CALL SE3A03(FUN) PRTD=-1.0E+30 RETURN END C------------------------------------------------- F88 = PRTDD FUNCTION PRTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='PRTDD' IF (MESS.NE.0) CALL SE3A03(FUN) PRTDD=-1.0E+30 RETURN END C------------------------------------------------- F94 = AJTPT FUNCTION AJTPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P*T FUN='AJTPT' IF (MESS.NE.0) CALL SE3A03(FUN) AJTPT=-1.0E+30 RETURN END C------------------------------------------------- F92 = BPPT FUNCTION BPPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P*T FUN='BPPT' IF (MESS.NE.0) CALL SE3A03(FUN) BPPT=-1.0E+30 RETURN END C------------------------------------------------- F90 = BSPT FUNCTION BSPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P*T FUN='BSPT' IF (MESS.NE.0) CALL SE3A03(FUN) BSPT=-1.0E+30 RETURN END C------------------------------------------------- F91 = BTPT FUNCTION BTPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P*T FUN='BTPT' IF (MESS.NE.0) CALL SE3A03(FUN) BTPT=-1.0E+30 RETURN END C------------------------------------------------- F93 = BVPT FUNCTION BVPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P*T FUN='BVPT' IF (MESS.NE.0) CALL SE3A03(FUN) BVPT=-1.0E+30 RETURN END C------------------------------------------------- F96 = GAMPDD FUNCTION GAMPDD(P) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P FUN='GAMPDD' IF (MESS.NE.0) CALL SE3A03(FUN) GAMPDD=-1.0E+30 RETURN END C------------------------------------------------- F95 = GAMPT FUNCTION GAMPT(P,T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=P*T FUN='GAMPT' IF (MESS.NE.0) CALL SE3A03(FUN) GAMPT=-1.0E+30 RETURN END C------------------------------------------------- F97 = GAMTDD FUNCTION GAMTDD(T) CHARACTER FUN*6 COMMON/UNIT/KPA,MESS X1=T FUN='GAMTDD' IF (MESS.NE.0) CALL SE3A03(FUN) GAMTDD=-1.0E+30 RETURN END C------------------------------------------------- F99 = PSBT FUNCTION PSBT(T) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'PSBT'/ C--- SET OF UNIT --- PBAR=G98A03(KPA,1.0) DT=DBLE(G99A03(KPA,T)) C--- FUNCTION CALL --- FF=F99A03(DT) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,2,DT,DT,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) PBAR=1.0 PSBT=SNGL(FF)/PBAR RETURN END C------------------------------------------------- F100 = TSBP FUNCTION TSBP(P) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6 INTEGER KPA,MESS COMMON/UNIT/KPA,MESS C--- FUNCTION NAME --- DATA FUN/'TSBP'/ C--- SET OF UNIT --- T0K=DBLE(G99A03(KPA,0.0)) DP=DBLE(G98A03(KPA,P)) C--- FUNCTION CALL --- FF=F100A03(DP) C--- ERROR CHECK & MESSAGE --- IF (MESS.NE.0) CALL SE1A03(FF,1,DP,DP,'P','T',FUN) C--- SUBSDTTUDTON OF THE VALUE INTO THE FUNCTION --- IF((FF.EQ.-1.0E+10).OR.(FF.EQ.-1.0E+20)) T0K=0.0 TSBP=SNGL(FF)-T0K RETURN END C *** FUNCTION FOR SETDTNG UNITS **** FUNCTION G98A03(KPA,P) IMPLICIT REAL*8 (D,F) IF(KPA.EQ.1) THEN PPA=1.0E05 ELSE IF(KPA.EQ.2) THEN PPA=1.0E05 ELSE IF(KPA.EQ.3) THEN PPA=1.0 ELSE PPA=1.0 END IF G98A03=P*PPA RETURN END FUNCTION G99A03(KPA,T) IMPLICIT REAL*8 (D,F) IF(KPA.EQ.1) THEN T0K=273.15E00 ELSE IF(KPA.EQ.2) THEN T0K=0.0 ELSE IF(KPA.EQ.3) THEN T0K=273.15E00 ELSE T0K=0.0 END IF G99A03=T+T0K RETURN END C ******* SUBROUDTNE FOR ERROR CHECK & MESSAGE ******* C *** LEVEL 1 & 2 ERROR - SUBROUTINE SE1A03(FF,IPT,DP,DT,N1,N2,FUN) IMPLICIT REAL*8 (D,F) CHARACTER FUN*6,N1*1,N2*1 C *** LEVEL 1 ERROR CHECK & MESSAGE - IF(FF.EQ.-1.0E+10) THEN WRITE(6,6000) FUN 6000 FORMAT(1H ,5X,'**** NO CONVERGENCE AT ',A6,' FOR WATER ****') C *** LEVEL 2 ERROR CHECK & MESSAGE - ELSE IF(FF.EQ.-1.0E+20) THEN IF (IPT.EQ.1) THEN C--- FUN(P) TYPED WRITE(6,6010) FUN,DP 6010 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR WATER', & ' WHEN P =',1PE14.7,' ****') C--- FUN(T) TYPE ELSE IF(IPT.EQ.2) THEN WRITE(6,6020) FUN,DT 6020 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR WATER', & ' WHEN T =',1PE14.7,' ****') C--- FUN(P,T) TYPE ELSE WRITE(6,6030) FUN,N1,DP,N2,DT 6030 FORMAT(1H ,5X,'**** OUT OF RANGE AT ',A6,' FOR WATER', &' WHEN ',A1,' =',1PE14.7,' AND ',A1,' =',1PE14.7,' ****') END IF END IF RETURN END C *** LEVEL 3 ERROR MESSAGE - SUBROUTINE SE3A03(FUN) CHARACTER FUN*6,MSG*125 MSG='**** FUNCTION '//FUN//' UNAVAILABLE FOR WATER ****' WRITE(6,100) MSG 100 FORMAT(1H ,5X,A) RETURN END C2**ALAPP DOUBLE PRECISION FUNCTION F2A03(PA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(PA.LE.611.657D00.OR.PA.GT.220.64D05) GO TO 920 IF(DABS(PA-220.64D05).LT.1.0D-3) GO TO 3 T = F40A03(PA) SVL = F49A03(PA) IF(SVL.LT.0.) GO TO 920 SVV = F50A03(PA) IF(SVV.LT.0.) GO TO 920 GRVT = 9.80665D00 SIGMA = F32A03(T) F2A03 = DSQRT(SIGMA*SVL*SVV/(GRVT*(SVV-SVL))) RETURN 3 F2A03 = 0.0 RETURN 920 CONTINUE F2A03 = -1.0E+20 RETURN END C3**ALAPT DOUBLE PRECISION FUNCTION F3A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF (T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF (DABS(T-647.096D00).LT.1.0D-3) GO TO 3 SVL = F53A03(T) IF (SVL.LT.0.) GO TO 920 SVV = F54A03(T) IF (SVV.LT.0.) GO TO 920 GRVT = 9.80665D00 SIGMA = F32A03(T) F3A03 = DSQRT(SIGMA*SVL*SVV/(GRVT*(SVV-SVL))) RETURN 3 F3A03 = 0.0 RETURN 920 CONTINUE F3A03 = -1.0E+20 RETURN END C4**ALHP DOUBLE PRECISION FUNCTION F4A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 HHL=F23A03(P) IF(HHL.LT.-100.0) GO TO 920 HHV=F24A03(P) IF(HHV.LT.0.) GO TO 920 700 F4A03=(HHV-HHL) RETURN 3 F4A03=0.0 RETURN 920 F4A03=-1.0E+20 RETURN END C5**ALHT DOUBLE PRECISION FUNCTION F5A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 HHL=F27A03(T) IF(HHL.LT.-100.0) GO TO 920 HHV=F28A03(T) IF(HHV.LT.0.) GO TO 920 700 F5A03=(HHV-HHL) RETURN 3 F5A03=0.0 RETURN 920 F5A03=-1.0E+20 RETURN END C21**CRP DOUBLE PRECISION FUNCTION F21A03(A) IMPLICIT DOUBLE PRECISION (A-H) CHARACTER*1 A,B(5) DATA B/'P','T','V','H','S'/ DO 20 I=1,5 IF(A.EQ.B(I)) GO TO (1,2,3,4,5), I 20 CONTINUE F21A03=-1.0E+20 RETURN 1 F21A03=22.064D06 RETURN 2 F21A03=647.096D00 RETURN 3 F21A03=3.1056D-03 RETURN 4 F21A03=2.0866D06 RETURN 5 F21A03=4.410D03 RETURN END C23**HPD DOUBLE PRECISION FUNCTION F23A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 T = F40A03(P) VOL=F53A03(T) CALL S3A03(T,DPDT,ALPH) F23A03=ALPH+T*VOL*DPDT RETURN 3 F23A03=2.0866D06 RETURN 920 F23A03=-1.0E+20 RETURN END C24**HPDD DOUBLE PRECISION FUNCTION F24A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 T = F40A03(P) VOLV=F54A03(T) CALL S3A03(T,DPDT,ALPH) F24A03=ALPH+T*VOLV*DPDT RETURN 3 F24A03=2.0866D06 RETURN 920 F24A03=-1.0E+20 RETURN END C27**HTX DOUBLE PRECISION FUNCTION F26A03(P,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(X.LT.0..OR.X.GT.1.0D00) GO TO 920 IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 HHL=F23A03(P) IF(HHL.LT.-100.0) GO TO 920 HHV=F24A03(P) IF(HHV.LT.0.) GO TO 920 700 F26A03=HHL+X*(HHV-HHL) RETURN 3 F26A03=2.0866D06 RETURN 920 F26A03=-1.0E+20 RETURN END C27**HTD DOUBLE PRECISION FUNCTION F27A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 VOL=F53A03(T) CALL S3A03(T,DPDT,ALPH) F27A03=ALPH+T*VOL*DPDT RETURN 3 F27A03=2.0866D06 RETURN 920 F27A03=-1.0E+20 RETURN END C28**HTDD DOUBLE PRECISION FUNCTION F28A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 VOLV=F54A03(T) CALL S3A03(T,DPDT,ALPH) F28A03=ALPH+T*VOLV*DPDT RETURN 3 F28A03=0.21073732D+07 RETURN 920 F28A03=-1.0E+20 RETURN END C29**HTX DOUBLE PRECISION FUNCTION F29A03(T,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(X.LT.0..OR.X.GT.1.0D00) GO TO 920 IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 HHL=F27A03(T) IF(HHL.LT.-100.0) GO TO 920 HHV=F28A03(T) IF(HHV.LT.0.) GO TO 920 700 F29A03=HHL+X*(HHV-HHL) RETURN 3 F29A03=2.0866D06 RETURN 920 F29A03=-1.0E+20 RETURN END C30**PST DOUBLE PRECISION FUNCTION F30A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA TC, PC/647.096D00, 22.064D06/ DATA A1, A2, A3, A4, A5, A6/-7.85951783D00, 1.84408259D00, & -11.7866497D00, 22.6807411D00, -15.9618719D00, 1.80122502D00/ IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 THITA=T/TC TAU=1.0D00-THITA AT1=A1*TAU+A2*TAU**1.5+A3*TAU**3.0+A4*TAU**3.5+A5*TAU**4.0+ & A6*TAU**7.5 F30A03 = PC*DEXP(TC/T*AT1) RETURN 920 F30A03 = -1.0E+20 RETURN END C31**SIGP DOUBLE PRECISION FUNCTION F31A03(PA) IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL RMJU DATA TC, BB, SB, RMJU /647.096D00, 235.8D-3, -0.625D00, 1.256E00/ IF (PA.LT.611.657D00.OR.PA.GT.220.64D05) GO TO 920 T = F40A03(PA) TAU = 1.0D00-T/TC F31A03 = BB*TAU**RMJU*(1.0D00+SB*TAU) RETURN 920 F31A03 = -1.0E20 RETURN END C32**SIGT DOUBLE PRECISION FUNCTION F32A03(T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL RMJU DATA TC, BB, SB, RMJU /647.096D00, 235.8D-3, -0.625D00, 1.256E00/ IF (T.LT.273.16D00.OR.T.GT.TC) GO TO 920 TAU = 1.0D00-T/TC F32A03 = BB*TAU**RMJU*(1.0D00+SB*TAU) RETURN 920 F32A03 = -1.0E20 RETURN END C33**SPD DOUBLE PRECISION FUNCTION F33A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 T = F40A03(P) VOL=F53A03(T) CALL S4A03(T,DPDT,PHI) F33A03=PHI+VOL*DPDT RETURN 3 F33A03=4.410D03 RETURN 920 F33A03=-1.0E+20 RETURN END C34**SPDD DOUBLE PRECISION FUNCTION F34A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 T = F40A03(P) VOLV=F54A03(T) CALL S4A03(T,DPDT,PHI) F34A03=PHI+VOLV*DPDT RETURN 3 F34A03=4.410D03 RETURN 920 F34A03=-1.0E+20 RETURN END C36**SPX DOUBLE PRECISION FUNCTION F36A03(P,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(X.LT.0.0.OR.X.GT.1.0D00) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 SSL=F33A03(P) IF(SSL.LT.-100.0) GO TO 920 SSV=F34A03(P) IF(SSV.LT.0.) GO TO 920 700 F36A03=SSL+X*(SSV-SSL) RETURN 3 F36A03=4.410D03 RETURN 920 F36A03=-1.0E+20 RETURN END C37**STD DOUBLE PRECISION FUNCTION F37A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 VOL=F53A03(T) CALL S4A03(T,DPDT,PHI) F37A03=PHI+VOL*DPDT RETURN 3 F37A03=4.410D03 RETURN 920 F37A03=-1.0E+20 RETURN END C38**STDD DOUBLE PRECISION FUNCTION F38A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 VOLV=F54A03(T) CALL S4A03(T,DPDT,PHI) F38A03=PHI+VOLV*DPDT RETURN 3 F38A03=4.410D03 RETURN 920 F38A03=-1.0E+20 RETURN END C39**STX DOUBLE PRECISION FUNCTION F39A03(T,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(X.LT.0..OR.X.GT.1.0D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 SSL=F37A03(T) IF(SSL.LT.-100.0) GO TO 920 SSV=F38A03(T) IF(SSV.LT.0.) GO TO 920 700 F39A03=SSL+X*(SSV-SSL) RETURN 3 F39A03=4.410D03 RETURN 920 F39A03=-1.0E+20 RETURN END C40**TSP DOUBLE PRECISION FUNCTION F40A03(P) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA TC, PC/647.096D00, 22.064D06/ DATA A1, A2, A3, A4, A5, A6/-7.85951783D00, 1.84408259D00, & -11.7866497D00, 22.6807411D00, -15.9618719D00, 1.80122502D00/ IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 ICONT=0 X1=647.096D00 250 THITA=X1/TC TAU=1.0D00-THITA AT1=A1*TAU+A2*TAU**1.5+A3*TAU**3.0+A4*TAU**3.5+A5*TAU**4.0+ & A6*TAU**7.5 FX=PC*DEXP(TC/X1*AT1)-P DAT1=A1+1.5D00*A2*TAU**0.5+3.0D00*A3*TAU**2.0+3.5D00*A4*TAU**2.5+ & 4.0D00*A5*TAU**3.0+7.5*A6*TAU**6.5 DFX=PC*(-DAT1/X1-TC/X1/X1*AT1)*DEXP(TC/X1*AT1) X2=X1-FX/DFX IF(DABS(X1-X2)/X2.LT.1.D-7) GO TO 300 ICONT=ICONT+1 X1=X2 GO TO 250 300 F40A03 = X2 RETURN 920 F40A03 = -1.0E+20 RETURN END C41**TRPL DOUBLE PRECISION FUNCTION F41A03(A) IMPLICIT DOUBLE PRECISION (A-H) CHARACTER*1 A,B(2) DATA B/'P','T'/ DO 20 I=1,2 IF(A.EQ.B(I)) GO TO (1,2), I 20 CONTINUE F41A03=-1.0E+20 RETURN 1 F41A03=611.2D-05 RETURN 2 F41A03=273.16D00 RETURN END C42**UPD DOUBLE PRECISION FUNCTION F42A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 HH=F23A03(P) IF(HH.LT.-100.0) GO TO 920 VV=F49A03(P) IF(VV.LT.0.) GO TO 920 F42A03=HH-P*VV RETURN 920 F42A03=-1.0E+20 RETURN END C43**UPDD DOUBLE PRECISION FUNCTION F43A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 HH=F24A03(P) IF(HH.LT.0.) GO TO 920 VV=F50A03(P) IF(VV.LT.0.) GO TO 920 F43A03=HH-P*VV RETURN 920 F43A03=-1.0E+20 RETURN END C45**UPX DOUBLE PRECISION FUNCTION F45A03(P,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(X.LT.0..OR.X.GT.1.0D00) GO TO 920 HHL=F23A03(P) IF(HHL.LT.-100.0) GO TO 920 HHV=F24A03(P) IF(HHV.LT.0.) GO TO 920 SVL=F49A03(P) IF(SVL.LT.0.) GO TO 920 SVV=F50A03(P) IF(SVV.LT.0.) GO TO 920 UUL=HHL-P*SVL UUV=HHV-P*SVV F45A03=UUL+X*(UUV-UUL) RETURN 920 F45A03=-1.0E+20 RETURN END C46**UTD DOUBLE PRECISION FUNCTION F46A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 P = F30A03(T) HH=F27A03(T) IF(HH.LT.-100.0) GO TO 920 VV=F53A03(T) IF(VV.LT.0.) GO TO 920 F46A03=HH-P*VV RETURN 920 F46A03=-1.0E+20 RETURN END C47**UTDD DOUBLE PRECISION FUNCTION F47A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 P = F30A03(T) HH=F28A03(T) IF(HH.LT.-100.0) GO TO 920 VV=F54A03(T) IF(VV.LT.0.) GO TO 920 F47A03=HH-P*VV RETURN 920 F47A03=-1.0E+20 RETURN END C48**UTX DOUBLE PRECISION FUNCTION F48A03(T,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(X.LT.0..OR.X.GT.1.0D00) GO TO 920 P = F30A03(T) HHL=F27A03(T) IF(HHL.LT.-100.0) GO TO 920 HHV=F28A03(T) IF(HHV.LT.0.) GO TO 920 SVL=F53A03(T) IF(SVL.LT.0.) GO TO 920 SVV=F54A03(T) IF(SVV.LT.0.) GO TO 920 UUL=HHL-P*SVL UUV=HHV-P*SVV F48A03=UUL+X*(UUV-UUL) RETURN 920 F48A03=-1.0E+20 RETURN END C49**VPD DOUBLE PRECISION FUNCTION F49A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA B1, B2, B3, B4, B5, B6/1.99274064D00, 1.09965342D00, & -0.510839303D00, -1.75493479D00, -45.5170352D00, -6.7469445D05/ DATA TC, RHOC/647.096D00, 322.0D00/ IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-2.212D02).GT.1.0D-3) GO TO 200 F49A03=3.10559D-3 RETURN 200 T = F40A03(P) THITA=T/TC TAU=1.0D00-THITA RHOL=RHOC*(1.0D00+B1*TAU**(1.0/3.0)+B2*TAU**(2.0/3.0)+ & B3*TAU**(5.0/3.0)+B4*TAU**(16.0/3.0)+B5*TAU**(43.0/3.0)+ & B6*TAU**(110.0/3.0)) F49A03=1.0D00/RHOL RETURN 920 F49A03=-1.0E+20 RETURN END C50**VPDD DOUBLE PRECISION FUNCTION F50A03(P) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA C1, C2, C3, C4, C5, C6/-2.0315024D00, -2.6830294D00, & -5.38626492D00, -17.2991605D00, -44.7586581D00, -63.9201063D00/ DATA TC, RHOC/647.096D00, 322.0D00/ IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-2.212D02).GT.1.0D-3) GO TO 200 F50A03=3.10559D-3 RETURN 200 T = F40A03(P) THITA=T/TC TAU=1.0D00-THITA RHOV=RHOC*DEXP(C1*TAU**(1.0/3.0)+C2*TAU**(2.0/3.0)+C3* &TAU**(4.0/3.0)+C4*TAU**3.0+C5*TAU**(37.0/6.0)+C6*TAU**(71.0/6.0)) F50A03=1.0D00/RHOV RETURN 920 F50A03=-1.0E+20 RETURN END C52**VPX DOUBLE PRECISION FUNCTION F52A03(P,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(X.LT.0..OR.X.GT.1.0D00) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 SVL=F49A03(P) IF(SVL.LT.0.) GO TO 920 SVV=F50A03(P) IF(SVV.LT.0.) GO TO 920 F52A03=SVL+X*(SVV-SVL) RETURN 3 F52A03=3.10559D-3 RETURN 920 F52A03=-1.0E+20 RETURN END C53**VTD DOUBLE PRECISION FUNCTION F53A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA B1, B2, B3, B4, B5, B6/1.99274064D00, 1.09965342D00, & -0.510839303D00, -1.75493479D00, -45.5170352D00, -6.7469445D05/ DATA TC, RHOC/647.096D00, 322.0D00/ IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).GT.1.0D-3) GO TO 200 F53A03=3.10559D-3 RETURN 200 THITA=T/TC TAU=1.0D00-THITA RHOL=RHOC*(1.0D00+B1*TAU**(1.0/3.0)+B2*TAU**(2.0/3.0)+ & B3*TAU**(5.0/3.0)+B4*TAU**(16.0/3.0)+B5*TAU**(43.0/3.0)+ & B6*TAU**(110.0/3.0)) F53A03=1.0D00/RHOL RETURN 920 F53A03=-1.0E+20 RETURN END C54**VTDD DOUBLE PRECISION FUNCTION F54A03(T) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA C1, C2, C3, C4, C5, C6/-2.0315024D00, -2.6830294D00, & -5.38626492D00, -17.2991605D00, -44.7586581D00, -63.9201063D00/ DATA TC, RHOC/647.096D00, 322.0D00/ IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-3.7415D02).GT.1.0D-3) GO TO 200 F54A03=3.10559D-3 RETURN 200 THITA=T/TC TAU=1.0D00-THITA RHOV=RHOC*DEXP(C1*TAU**(1.0/3.0)+C2*TAU**(2.0/3.0)+C3* &TAU**(4.0/3.0)+C4*TAU**3.0+C5*TAU**(37.0/6.0)+C6*TAU**(71.0/6.0)) F54A03=1.0D00/RHOV RETURN 920 F54A03=-1.0E+20 RETURN END C55**VTX DOUBLE PRECISION FUNCTION F55A03(T,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(X.LT.0..OR.X.GT.1.0D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 SVL=F53A03(T) IF(SVL.LT.0.) GO TO 920 SVV=F54A03(T) IF(SVV.LT.0.) GO TO 920 800 F55A03=SVL+X*(SVV-SVL) RETURN 3 F55A03=3.10559D-3 RETURN 920 F55A03=-1.0E+20 RETURN END C56**XPH DOUBLE PRECISION FUNCTION F56A03(P,HH) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(HH.LT.-42.2.OR.HH.GT.2.805D+6) GO TO 920 IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 HHL=F23A03(P) IF(HHL.LT.-100.0) GO TO 920 HHV=F24A03(P) IF(HHV.LT.0.) GO TO 920 700 F56A03=(HH-HHL)/(HHV-HHL) RETURN 3 F56A03=0.0 RETURN 920 F56A03=-1.0E+20 RETURN END C57**XPS DOUBLE PRECISION FUNCTION F57A03(P,SS) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(SS.LT.-0.16.OR.SS.GT.9.158D03) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 SSL=F33A03(P) IF(SSL.LT.-100.0) GO TO 920 SSV=F34A03(P) IF(SSV.LT.0.) GO TO 920 700 F57A03=(SS-SSL)/(SSV-SSL) RETURN 3 F57A03=0.0 RETURN 920 F57A03=-1.0E+20 RETURN END C58**XPU DOUBLE PRECISION FUNCTION F58A03(P,UU) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(UU.LT.-4.218D+01.OR.UU.GT.2.605D+06) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 UUL=F42A03(P) IF(UUL.LT.-100.0) GO TO 920 UUV=F43A03(P) IF(UUV.LT.0.) GO TO 920 F58A03=(UU-UUL)/(UUV-UUL) RETURN 3 F58A03=0.0 RETURN 920 F58A03=-1.0E+20 RETURN END C59**XPV DOUBLE PRECISION FUNCTION F59A03(P,VV) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(P.LE.611.657D00.OR.P.GT.22.064D06) GO TO 920 IF(VV.LT.1.D-03.OR.VV.GT.2.0631D+02) GO TO 920 IF(DABS(P-22.064D06).LT.1.0D-3) GO TO 3 SVL=F49A03(P) IF(SVL.LT.0.) GO TO 920 SVV=F50A03(P) IF(SVV.LT.0.) GO TO 920 F59A03=(VV-SVL)/(SVV-SVL) RETURN 3 F59A03=0.0 RETURN 920 F59A03=-1.0E+20 RETURN END C60**XTH DOUBLE PRECISION FUNCTION F60A03(T,HH) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(HH.LT.-42.2.OR.HH.GT.2.805D+6) GO TO 920 IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 HHL=F27A03(T) IF(HHL.LT.-100.0) GO TO 920 HHV=F28A03(T) IF(HHV.LT.0.) GO TO 920 700 F60A03=(HH-HHL)/(HHV-HHL) RETURN 3 F60A03=0.0 RETURN 920 F60A03=-1.0E+20 RETURN END C61**XTS DOUBLE PRECISION FUNCTION F61A03(T,SS) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(SS.LT.-0.16.OR.SS.GT.9.158D03) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 SSL=F37A03(T) IF(SSL.LT.-100.0) GO TO 920 SSV=F38A03(T) IF(SSV.LT.0.) GO TO 920 700 F61A03=(SS-SSL)/(SSV-SSL) RETURN 3 F61A03=0.0 RETURN 920 F61A03=-1.0E+20 RETURN END C62**XTU DOUBLE PRECISION FUNCTION F62A03(T,UU) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(UU.LT.-4.218D+01.OR.UU.GT.2.605D+06) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 UUL=F46A03(T) IF(UUL.LT.-100.0) GO TO 920 UUV=F47A03(T) IF(UUV.LT.0.) GO TO 920 F62A03=(UU-UUL)/(UUV-UUL) RETURN 3 F62A03=0.0 RETURN 920 F62A03=-1.0E+20 RETURN END C63**XTV DOUBLE PRECISION FUNCTION F63A03(T,VV) IMPLICIT DOUBLE PRECISION(A-H,O-Z) IF(T.LT.273.16D00.OR.T.GT.647.096D00) GO TO 920 IF(VV.LT.1.D-03.OR.VV.GT.2.0631D+02) GO TO 920 IF(DABS(T-647.096D00).LT.1.0D-3) GO TO 3 SVL=F53A03(T) IF(SVL.LT.0.) GO TO 920 SVV=F54A03(T) IF(SVV.LT.0.) GO TO 920 F63A03=(VV-SVL)/(SVV-SVL) RETURN 3 F63A03=0.0 RETURN 920 F63A03=-1.0E+20 RETURN END C68**PMLT *** MELTING PRESSURE DOUBLE PRECISION FUNCTION F68A03(TA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA TN, PN, TMIN / 273.16D00, 611.657D00, 251.165D00 / IF (TA.GT.273.16001D00.OR.TA.LT.TMIN) GO TO 920 THITA = TA/TN PA = 1.0-0.626D06*(1.0D00-THITA**(-3.0))+0.197135D06* & (1.0D00-THITA**21.2) F68A03 = PA*PN RETURN 920 F68A03 = -1.0E+20 END C69**TMLP *** MELTING TEMPERATURE DOUBLE PRECISION FUNCTION F69A03(PA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA TN, PN, PMAX / 273.16D00, 611.657D00, 209.9D06 / IF (PA.LT.PN.OR.PA.GT.PMAX) GO TO 920 X1 = TN 250 THITA = X1/TN PXX = 1.0-0.626D06*(1.0D00-THITA**(-3.0))+0.197135D06* & (1.0D00-THITA**21.2) FX = PN*PXX-PA DFX = -1.878D06*TN**3/(X1**2)-4.179262D06*X1**20.2/TN**21.2 X2 = X1-FX/DFX ICONT = ICONT+1 IF(DABS(X2-X1)/X2.LE.1.0D-7) GO TO 300 X1 = X2 GO TO 250 300 F69A03 = X2 RETURN 920 F69A03 = -1.0E+20 RETURN END C99**PSBT *** SUBLIMATION PRESSURE DOUBLE PRECISION FUNCTION F99A03(TA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA A1, A2,A3/19.267D00, -3.87002D00, 1.67595D00/ DATA TN, PN, TMIN/ 273.16D00, 611.657D00, 190.0D00 / IF (TA.GT.TN.OR.TA.LT.TMIN) GO TO 920 THITA = TA/TN PA = PN*DEXP(A1*(1.0D00-THITA**(-1.0))+A2*(1.0D00-THITA**3.0) & +A3*(1.0D00-THITA**5.0)) F99A03 = PA RETURN 920 F99A03 = -1.0E+20 END C100**TSBP *** SUBLIMATION TEMPERATURE DOUBLE PRECISION FUNCTION F100A03(PA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DATA A1, A2,A3/19.267D00, -3.87002D00, 1.67595D00/ DATA TN, PN, PMIN / 273.16D00, 611.657D00, 41.532D-3 / IF (PA.GE.PN.OR.PA.LT.PMIN) GO TO 920 ICONT = 0 X1 = TN 250 THITA = X1/TN PX = DEXP(A1*(1.0D00-THITA**(-1.0))+A2*(1.0D00-THITA**3.0) & +A3*(1.0D00-THITA**5.0)) FX = PN*PX-PA DFX = PN*(A1*TN/(X1*X1)-3.0D00*A2*X1*X1/(TN**3)-5.0D00*A3*X1**4 & /(TN**5))*PX X2 = X1-FX/DFX IF (DABS(X2-X1)/X2.LT.1.0D-5) GO TO 300 X1 = X2 ICONT = ICONT+1 GO TO 250 300 F100A03 = X2 RETURN 920 F100A03 = -1.0E+20 RETURN END C *** SUB 3 SUBROUTINE S3A03(T,DPDT,ALPH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA TC, PC, ALPH0/647.096D00, 22.064D06, 1000.0D00/ DATA A1, A2, A3, A4, A5, A6/-7.85951783D00, 1.84408259D00, & -11.7866497D00, 22.6807411D00, -15.9618719D00, 1.80122502D00/ DATA D1, D2, D3, D4, D5/-5.65134998D-8, 2690.66631D00, & 127.287297D00, -135.003439D00, 0.981825814D00/ DATA DALPH/-1135.905627715D00/ THITA=T/TC TAU=1.0D00-THITA ALPH=ALPH0*(DALPH+D1*THITA**(-19.0)+D2*THITA+D3*THITA**4.5+D4* & THITA**5.0+D5*THITA**54.5) AT1=A1*TAU+A2*TAU**1.5+A3*TAU**3.0+A4*TAU**3.5+A5*TAU**4.0 & +A6*TAU**7.5 DAT1=A1+1.5D00*A2*TAU**0.5+3.0D00*A3*TAU**2.0+3.5D00*A4*TAU**2.5 & +4.0D00*A5*TAU**3.0+7.5*A6*TAU**6.5 DPDT = PC*(-DAT1/T-TC/T/T*AT1)*DEXP(TC/T*AT1) RETURN END C *** SUB 4 SUBROUTINE S4A03(T,DPDT,PHI) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA TC, PC, PHI0/647.096D00, 22.064D06, 1.54536576D00/ DATA A1, A2, A3, A4, A5, A6/-7.85951783D00, 1.84408259D00, & -11.7866497D00, 22.6807411D00, -15.9618719D00, 1.80122502D00/ DATA D1, D2, D3, D4, D5/-5.65134998D-8, 2690.66631D00, & 127.287297D00, -135.003439D00, 0.981825814D00/ DATA DPHI/ 2319.5246D00/ THITA=T/TC TAU=1.0D00-THITA PHI=PHI0*(DPHI+0.95D00*D1*THITA**(-20.0)+D2*DLOG(THITA)+ & 1.285714286D00*D3*THITA**3.5+1.25D00*D4*THITA**4.0+ & 1.018691589D00*D5*THITA**53.5) AT1=A1*TAU+A2*TAU**1.5+A3*TAU**3.0+A4*TAU**3.5+A5*TAU**4.0+ & A6*TAU**7.5 DAT1=A1+1.5D00*A2*TAU**0.5+3.0D00*A3*TAU**2.0+3.5D00*A4*TAU**2.5+ & 4.0D00*A5*TAU**3.0+7.5*A6*TAU**6.5 DPDT = PC*(-DAT1/T-TC/T/T*AT1)*DEXP(TC/T*AT1) RETURN END C *** SUB 5 SUBROUTINE S5A03(T,RHOL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA B1, B2, B3, B4, B5, B6/1.99274064D00, 1.09965342D00, & -0.510839303D00, -1.75493479D00, -45.5170352D00, -6.7469445D05/ DATA TC, RHOC/647.096D00, 322.0D00/ 200 THITA = T/TC TAU = 1.0D00-THITA RHOL = RHOC*(1.0D00+B1*TAU**(1.0/3.0)+B2*TAU**(2.0/3.0)+ & B3*TAU**(5.0/3.0)+B4*TAU**(16.0/3.0)+B5*TAU**(43.0/3.0)+ & B6*TAU**(110.0/3.0)) RETURN END C *** SUB 6 SUBROUTINE S6A03(T,RHOV) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA C1, C2, C3, C4, C5, C6/-2.0315024D00, -2.6830294D00, & -5.38626492D00, -17.2991605D00, -44.7586581D00, -63.9201063D00/ DATA TC, RHOC/647.096D00, 322.0D00/ 200 THITA = T/TC TAU = 1.0D00-THITA RHOV = RHOC*DEXP(C1*TAU**(1.0/3.0)+C2*TAU**(2.0/3.0)+C3* &TAU**(4.0/3.0)+C4*TAU**3.0+C5*TAU**(37.0/6.0)+C6*TAU**(71.0/6.0)) 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