diff options
| author | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
|---|---|---|
| committer | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
| commit | 7dfcc480ba1e19bd3232349fc733caef94034292 (patch) | |
| tree | 03ee104eb8846d5cc1a981d267687a729185d3f3 /Utilib/src | |
Initial commit from Polytechnique Montreal
Diffstat (limited to 'Utilib/src')
136 files changed, 15512 insertions, 0 deletions
diff --git a/Utilib/src/ADDBLE.f b/Utilib/src/ADDBLE.f new file mode 100644 index 0000000..6955c9d --- /dev/null +++ b/Utilib/src/ADDBLE.f @@ -0,0 +1,36 @@ +*DECK ADDBLE + SUBROUTINE ADDBLE(NSIZE,IPOS,DSUM,DINC) +*----------------------------------------------------------------------- +* +*Purpose: +* add a double to a vector of doubles. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NSIZE size of double array. +* IPOS position in double array. +* DINC double to be added. +* +*Parameters: input/output +* DSUM double array. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NSIZE,IPOS + DOUBLE PRECISION DSUM(NSIZE),DINC +* + DSUM(IPOS) = DSUM(IPOS) + DINC +* + RETURN + END diff --git a/Utilib/src/AFERF.f b/Utilib/src/AFERF.f new file mode 100644 index 0000000..9e92961 --- /dev/null +++ b/Utilib/src/AFERF.f @@ -0,0 +1,55 @@ +*DECK AFERF + FUNCTION AFERF (XX) +C +C----------------------------------------------------------------------- +C +C ERROR FUNCTION. +C +C----------------------------------------------------------------------- +C + IMPLICIT NONE +C---- +C FUNCTION +C---- + REAL AFERF +C---- +C VARIABLES +C---- + REAL A0,A1,A2,A3,A4,A5,A6,B0,B1,B2,B3, + & B4,B5,B6,B7,D1,D2,X,XX,Z,Y + INTEGER IS +C---- + DATA A0 / 0.12837912 /, A1 / -0.37612384 /, A2 / 0.11281417 / + 1 , A3 / -0.26782287E-01 /, A4 / 0.50805667E-02 / + 2 , A5 / -0.72514300E-03 /, A6 / 0.58167427E-04 / + 3 , B0 / 0.39141751E-02 /, B1 / -0.17582889E-01 / + 4 , B2 / 0.35873539E-01 /, B3 / -0.42869095E-01 / + 5 , B4 / 0.32161925E-01 /, B5 / -0.11846550E-01 / + 6 , B6 / 0.30705572E-02 /, B7 / 0.59813837E-02 / + 7 , D1,D2 / 1.317, 2.040001 / +C + X=XX + IF (X.GE.0.) THEN + IS=2 + ELSE + IS=1 + X=-X + ENDIF + IF (X.GT.D1) GO TO 8 + Z=X*X + Y=(((((A6*Z+A5)*Z+A4)*Z+A3)*Z+A2)*Z+A1)*Z+A0 + Y=X*Y+X + GO TO 6 + 8 IF (X.GT.D2) GO TO 10 + X=X-D2 + Y=((((((B7*X+B6)*X+B5)*X+B4)*X+B3)*X+B2)*X+B1)*X+B0 + GO TO 7 + 10 Y=1. + GO TO 6 + 7 Y=1.-Y + 6 GO TO (17,18),IS + 17 AFERF=-Y + GO TO 30 + 18 AFERF=Y + 30 RETURN + END diff --git a/Utilib/src/AIKINT.f b/Utilib/src/AIKINT.f new file mode 100644 index 0000000..444f127 --- /dev/null +++ b/Utilib/src/AIKINT.f @@ -0,0 +1,264 @@ +*DECK AIKINT + FUNCTION AIKINT(Z,X,Y,N,EPS) +C---- +C REVISION HISTORY +C - CREATED 80-AUG, BY E.G. LONG +C - CHECK THAT X-VALUES ARE MONOTONICALLY INCREASING, +C - REVISED FROM AELIB 1985 OCT 16 BY P CARLSON +C - CHANGED TO RELATIVE EPS AUGUST 1986 JV DONNELLY +C - IMPLEMENTED IN DRAGON AUGUST 1993 (G. MARLEAU) +C ABNORMAL TERMINATION +C 1. PARAMETER CHECKS FAIL- +C A. X NOT MONOTONICALLY INCREASING +C 2. REQUESTED ACCURACY NOT OBTAINED +C PARAMETERS +C Z : INTERPOLATION POINT +C X : INTERPOLATION POINT TABLULATION +C Y : TABULATED FUNCTION AT POINTS X +C N : NUMBER OF TABULATED POINTS +C EPS : TABULATION ERROR PERMITTED +C---- + SAVE ICALLB,ICALLA + PARAMETER (IOUT=6) + LOGICAL RELOK,ABSOK + REAL X(N),Y(N),W(10),F(10) + DATA ICALLB,ICALLA /0,0/ +C---- +C CHECK FOR MONOTONICALLY INCREASING TABLE +C---- + IL=0 + MC=0 + IF(N.GE.2) THEN + DO 120 I = 2, N + IF (X(I) .LE. X(I-1)) THEN + WRITE(IOUT,2000) + CALL XABORT('AIKINT: ILLEGAL FORMAT TABLE') + ENDIF + 120 CONTINUE + ENDIF +C---- +C HANDLE INTEROPOLATION WITH N<=2 +C---- + IF(N.LE.2) THEN + IF(N.LE.0) AIKINT=0.0 + IF(N.EQ.1) AIKINT=Y(1) + IF(N.EQ.2) AIKINT=((Z-X(2))*Y(1)-(Z-X(1))*Y(2)) + > /(X(1) - X(2)) +C---- +C RETURN FROM AIKINT +C---- + RETURN + ENDIF +C---- +C INTERPOLATION FOR N>2 +C CHECK IF Z=X(1) +C---- + IX=1 + IF(X(1).NE.Z) GO TO 20 +C---- +C Z IS AT ONE OF X(I) +C---- + 21 CONTINUE + AIKINT=Y(IX) +C---- +C RETURN FROM AIKINT +C---- + RETURN +C +C----------------------------------------------------------- + 20 CONTINUE + IF(X(IX).GT.Z) THEN +C---- +C EXTRAPOLATION BEFORE TABLE BEGINS +C---- + IF(ICALLB.EQ.0) WRITE(IOUT,2001) + ICALLB=ICALLB+1 + IU = 1 + JA = 1 + K = 2 + NA=MIN0(N,10) + DO 40 I=1,NA + W(I) = X(I) + F(I) = Y(I) + 40 CONTINUE + GO TO 600 + ELSE +C---- +C CHECK IF Z=X(N) +C---- + IX=N + IF(X(IX).EQ.Z) GO TO 21 + IF(X(IX).LT.Z) THEN +C---- +C EXTRAPOLATION BEYOND END OF TABLE +C---- + IF(ICALLA.EQ.0) WRITE(IOUT,2002) +C ICALLA=ICALLA+1 +C IL=N +C JA=2 +C K=2 +C NA=MIN0(N,10) +C DO 41 I=1,NA +C J = N - I + 1 +C W(I) = X(J) +C F(I) = Y(J) +C 41 CONTINUE +C GO TO 600 + AIKINT=Y(N) + RETURN + ENDIF + ENDIF +C---- +C Z IS WITHIN X(I), FIND WHERE Z LIES IN THE TABLE +C---- + IL = 1 + IU = N + JA = 3 + A = N + M = INT(ALOG(FLOAT(N))/0.693147) + 2 + DO 11 I = 1, M + IR = IU - IL + IF( IR .EQ. 1 ) GO TO 30 + IX = IL + IR/2 + IF( X(IX) .EQ. Z ) GO TO 21 + IF( X(IX) .GT. Z ) THEN + IU = IX + ELSE + IL = IX + ENDIF + 11 CONTINUE + IU = N + IL = N - 1 + 30 CONTINUE + K=0 + MC=3 +C---- +C FINDING NEAREST ARGUMENTS TO Z +C IF POSSIBLE, THE ARGUMENTS ARE CHOSEN IN PAIRS, SO THAT THEY ARE +C ON THE SAME SIDE OF Z. THE FIRST LINEAR CROSS MEANS IS +C CALCULATED USING THE CLOSEST PAIR. SUBSEQUENT LINEAR CROSS +C MEANS ARE CALCULATED USING FIRST THE CLOSEST ARGUMENT TO Z OF +C THE NEXT PAIR AND THEN THE OTHER ARGUMENT +C OTHERWISE THE ARGUMENTS ARE CHOSEN IN ORDER OF CLOSENESS. +C---- + NA=MIN0(N,10) + 601 IF( K .EQ. NA ) GO TO 501 + I450=1 + I400=1 + IF( IU .EQ. (N+1) ) THEN + I450=0 + I400=0 + ELSE IF( IL .EQ. 0) THEN + I450=0 + ELSE IF(MC-2 .EQ. -1) THEN + I450=0 + I400=0 + ELSE IF(MC-2 .EQ. 0) THEN + I450=0 + ENDIF +* I450 + IF( I450 .EQ. 1) THEN + MC=0 + D1=ABS(X(IU)-Z) + D2=ABS(X(IL)-Z) + IF( D1 .GT. D2 ) THEN + I400=0 + ENDIF + ENDIF +* I400 + IF( I400 .EQ. 1) THEN + MC = MC + 1 + K = K + 1 + F(K) = Y(IU) + W(K) = X(IU) + IU = IU + 1 + ELSE + MC = MC + 2 + K = K + 1 + F(K) = Y(IL) + W(K) = X(IL) + IL = IL - 1 + ENDIF + IF(K .LT. 2) GO TO 601 +C---- +C EVALUATION OF POSSIBLE ANSWERS +C---- + 600 CONTINUE + KA = K - 1 + DO 200 I= 1, KA + F(K) = ( ( Z - W(K) )*F(I) - + > ( Z - W(I) )*F(K) )/( W(I) - W(K) ) + 200 CONTINUE +C---- +C TEST FOR CONVERGENCE OF INTERPOLATION +C---- + IF( F(KA) .EQ. 0.0 ) THEN + IF( ABS(F(K)) .LT. EPS ) THEN + AIKINT = F(K) + RETURN + ENDIF + ELSE + IF( ABS( 1. - F(K)/F(KA) ) .LT. EPS) THEN + AIKINT = F(K) + RETURN + ENDIF + ENDIF +C---- +C NOT CONVERGED YET, TRY NEXT ORDER IF POSSIBLE +C---- + IF( JA .GT. 2 ) GO TO 601 + IF( K .EQ. NA ) GO TO 501 + K = K + 1 + GO TO 600 +C---- +C REQUESTED ACCURACY WAS NOT OBTAINED +C REVERT TO LEAST DIVERGENT INTERPOLATION +C BASED ON RELATVE AND ABSOLUTE CONVERGENCE +C---- + 501 CONTINUE + KR = 1 + CONR = 100. + KA = 1 + CONA = 100.*ABS(F(1)) + ABSOK = .TRUE. + RELOK = .TRUE. + DO 10 I = 2, NA + IF( F(I-1) .NE. 0.0 ) THEN + CON = ABS( 1.0 - F(I)/F(I-1) ) + ELSE + CON = 1.0 + ENDIF + IF( RELOK .AND. CON .LT. CONR ) THEN + KR = I + CONR = CON + ELSE + RELOK = .FALSE. + ENDIF + CON = ABS( F(I) - F(I-1) ) + IF( ABSOK .AND. CON .LT. CONA ) THEN + KA = I + CONA = CON + ELSE + ABSOK = .FALSE. + ENDIF + 10 CONTINUE + IF( KR .GT. KA ) THEN + KK = KR + CONMIN = CONR + ELSE + KK = KA + CONMIN = CONA + IF( F(KK) .NE. 0.0 ) CONMIN = CONMIN/F(KK) + ENDIF + AIKINT = F(KK) + RETURN +C---- +C FORMAT +C---- + 2000 FORMAT(' --- ERROR IN AIKINT: X-VALUES ARE', + > ' NOT MONOTONICALLY INCREASING ---') + 2001 FORMAT(' --- WARNING FROM AIKINT: EXTRAPOLATION', + > ' BEFORE TABLE BEGINS AT LEAST ONCE ---') + 2002 FORMAT(' --- WARNING FROM AIKINT: EXTRAPOLATION', + > ' BEYOND END OF TABLE AT LEAST ONCE ---') + END diff --git a/Utilib/src/AK0BES.f b/Utilib/src/AK0BES.f new file mode 100644 index 0000000..ab78a21 --- /dev/null +++ b/Utilib/src/AK0BES.f @@ -0,0 +1,68 @@ +*DECK AK0BES + FUNCTION AK0BES(X) +C +C FUNCTION TO COMPUTE BESSEL FUNCTION K0(X) +C X ARGUMENT, REAL AND POSITIVE +C IF X INDEFINITE OR INFINITE, ROUTINE SETS RESULT TO INDEFINITE, +C ISSUES MESSAGE, AND RETURNS +C METHOD- FOR X.LT.1 , K0(X)=-ALOG I0(X)+P3(X**2)/Q3(X**2) +C FOR X.GE.1, K0(X)=(1/SQRT(X))*EXP(-X)*P6(Z)/Q7(Z) WHERE Z=1/X +C COEFFICIENTS OF P AND Q GIVEN IN AECL-3461 +C COEFFICIENTS OF I0(X) GIVEN IN AECL-3461 +C PROGRAMMED BY B. PURCELL JULY 1975 +C MODIFICATION OF AIKBES +C +C TAKEN FROM *AELIB* LIBRARY +C MODIFY BY R.ROY (JULY 1994) IN DOUBLE PRECISION +C + DOUBLE PRECISION AK0BES,X,P(4),Q(3),R(4),S(3),H(7),V(7) + DOUBLE PRECISION A,B,C,D,E,F,G,U,Z,XSQ,SQRTX + SAVE + DATA P/-3.95157677473120D4, -9.39640131154667D4, + > -5.90621631658113D3, -8.03837079456277D1 / + DATA Q/-3.40854404627503D5, 9.73445375796915D3, + > -1.35884289391378D2 / + DATA R/-4.61386437648537D5, -1.03155855077145D5, + > -4.31585225221548D3, -4.73684318951378D1/ + DATA S/-4.61386437648537D5, 1.21907543350014D4, + > -1.54377747904204D2 / + DATA H/ 1.75426986999764D2, 1.81039368258996D3, + > 6.39989885473113D3, 9.57620781628533D3, + > 6.07187112523892D3, 1.42043536504859D3, + > 8.10958280123701D1 / + DATA V/ 1.39970484475278D2, 1.46198147887226D3, + > 5.27928649717172D3, 8.20807534468755D3, + > 5.59084277299757D3, 1.50955451467318D3, + > 1.21349566357318D2 / +C +C TEST FOR ARGUMENT.LE.0 +C + AK0BES=0.0D0 + IF(X.LE.0.D0) GOTO 10 + IF(X.GT.1.D0) GOTO 5 +C +C THIS BRANCH FOR X.LT.1 +C + XSQ=X*X + A=((P(4)*XSQ+P(3))*XSQ+P(2))*XSQ+P(1) + B=((XSQ+Q(3))*XSQ+Q(2))*XSQ+Q(1) + C=A/B + D=((R(4)*XSQ+R(3))*XSQ+R(2))*XSQ+R(1) + E=((XSQ+S(3))*XSQ+S(2))*XSQ+S(1) + F=D/E + AK0BES=-LOG(X)*F+C + RETURN +C +C THIS PART OF THE PROGRAM CALCULATES K0(X) FOR X.GT.1 +C + 5 SQRTX=SQRT(X) + Z=1.D0/X + G=(((((H(7)*Z+H(6))*Z+H(5))*Z+H(4))*Z+H(3))*Z+H(2))*Z+H(1) + U=((((((Z+V(7))*Z+V(6))*Z+V(5))*Z+V(4))*Z+V(3))*Z+V(2))*Z+V(1) + AK0BES=(1.D0/SQRTX)*(EXP(-X))*G/U + RETURN +C +C ERROR SECTION FOR X.LE.0 + 10 CALL XABORT('AK0BES: ILLEGAL ARGUMENT FOR BESSEL K0') + RETURN + END diff --git a/Utilib/src/AK1BES.f b/Utilib/src/AK1BES.f new file mode 100644 index 0000000..55ff28d --- /dev/null +++ b/Utilib/src/AK1BES.f @@ -0,0 +1,69 @@ +*DECK AK1BES + FUNCTION AK1BES(X) +C +C FUNCTION TO COMPUTE BESSEL FUNCTION K1(X) +C X ARGUMENT, REAL AND POSITIVE +C IF X INDEFINITE OR INFINITE, ROUTINE SETS RESULT TO INDEFINITE, +C ISSUES MESSAGE, AND RETURNS +C METHOD-FOR X.LT.1 , K1(X)=ALOG I1(X)+1/X+X*P3(X**2)/Q3(X**2) +C FOR X.GE.1, K1(X)=(1/SQRT(X))*EXP(-X)*P6(Z)/Q7(Z) WHERE Z=1/X +C COEFFICIENTS OF P AND Q GIVEN IN AECL-3461 +C COEFFICIENTS OF I1(X) GIVEN IN AECL-3461 +C PROGRAMMED BY B. PURCELL JULY 1975 +C MODIFICATION OF AIKBES +C +C TAKEN FROM *AELIB* LIBRARY +C MODIFY BY R.ROY (JULY 1994) IN DOUBLE PRECISION +C + DOUBLE PRECISION AK1BES,X,P(4),Q(3),R(5),H(8),V(7) + DOUBLE PRECISION A,B,C,D,E,F,G,U,Z,XSQ,SQRTX + SAVE + DATA P/ 2.05653783869908D5, 5.21490277398084D4, + > 1.80714545607523D3, 1.66644511883896D1 / + DATA Q/-6.67781331663377D5, 1.57807971896305D4, + > -1.76644575202506D2 / + DATA R/-6.04290103419901D1, -7.05362629269085D0, + > -2.52234429536922D-1,-3.9527977417420D-3, + > -2.77141112612D-5 / + DATA H/ 5.05657074674356D1, 5.86274965274502D2, + > 2.43240313288218D3, 4.58937398896551D3, + > 4.14893728249324D3, 1.73179927703691D3, + > 2.87833733475985D2, 1.24115199887274D1 / + DATA V/ 4.03455972943410D1, 4.52650144192445D2, + > 1.77576110097515D3, 3.04478817648148D3, + > 2.33607774590470D3, 7.34544788193384D2, + > 7.34518391966755D1 / +C +C TEST FOR ARGUMENT.LE.0 +C + AK1BES=0.0D0 + IF(X.LE.0.D0) GOTO 10 + IF(X.GT.1.D0) GOTO 5 +C +C THIS BRANCH FOR X.LT.1 +C + XSQ=X*X + A=((P(4)*XSQ+P(3))*XSQ+P(2))*XSQ+P(1) + B=((XSQ+Q(3))*XSQ+Q(2))*XSQ+Q(1) + C=A/B + D=(((R(5)*XSQ+R(4))*XSQ+R(3))*XSQ+R(2))*XSQ+R(1) + E=-1.20858020683979D2+XSQ + F=D/E + AK1BES= LOG(X)*X*F+1.D0/X+X*C + RETURN +C +C THIS PART OF THE PROGRAM CALCULATES K1(X) FOR X.GT.1 +C + 5 SQRTX=SQRT(X) + Z=1.D0/X + G=((((((H(8)*Z+H(7))*Z+H(6))*Z+H(5))*Z+H(4))*Z+H(3))*Z+H(2))*Z + > + H(1) + U=((((((Z+V(7))*Z+V(6))*Z+V(5))*Z+V(4))*Z+V(3))*Z+V(2))*Z+V(1) + AK1BES=(1.D0/SQRTX)*(EXP(-X))*G/U + RETURN +C +C +C ERROR SECTION FOR X.LE.0 + 10 CALL XABORT('AK1BES: ILLEGAL ARGUMENT FOR BESSEL K1') + RETURN + END diff --git a/Utilib/src/AKIN10.f b/Utilib/src/AKIN10.f new file mode 100644 index 0000000..b7fe2eb --- /dev/null +++ b/Utilib/src/AKIN10.f @@ -0,0 +1,272 @@ +*DECK AKIN10 + SUBROUTINE AKIN10(X,AKIN) +C +C THE SUBROUTINE AKIN10 EVALUATES THE BICKLEY FUNCTIONS KIN(X), +C N = 1,2,...,10, X \ 0, TO A MINIMUM PRECISION OF 12.75 SIGNIFICANT +C FIGURES AND RETURNS THE VALUES KIN(X),N = 1,2,...,10 IN THE ARRAY AKIN +C +C +C ARGUMENT LIST: +C +C X - REAL, X \ 0. +C AKIN - REAL, ONE DIMENSIONAL ARRAY TO STORE KIN(X),N = 1,2,...,10 +C +C +C METHOD: +C +C THE BICKLEY FUNCTIONS SATISFY A RECURSIVE RELATION ENABLING A FUNCTION +C OF ANY ORDER TO BE FOUND IF THREE BICKLEY FUNCTIONS OF CONSECUTIVE +C ORDER ARE KNOWN. THE FORMULA FOR FORWARD RECURSION IS: +C (KI(N))(X) = (X * ((KI(N-3))(X) - (KI(N-1))(X)) / (N-1)) +C + ((N-2) * (KI(N-2))(X)) / (N-1) +C THE FORMULA FOR BACKWARD RECURSION IS: +C (KI(N))(X) = ((N+2) * (KI(N+3))(X)) / X + (KI(N+2))(X) +C - ((N+1) * (KI(N+1))(X)) / X +C FORWARD AND BACKWARD RECURSION WERE TESTED \ SEE "APPROXIMATING THE +C BICKLEY FUNCTIONS KIN(X),N=1,2,...,10",C.A.EDWARDS!. LEAST LOSS OF +C PRECISION WAS OBTAINED BY USING FORWARD RECURSION FOR 0@X@6, AND +C BACKWARD RECUSION FOR X\6. +C +C X \ 6. KI,(X),KI9(X),KI10(X) ARE CALCULATED AND USED IN BACKWARD +C RECURSION TO DERIVE KIN(X),N=7,6,...,1 +C +C 0 < X < 6. KI1(X),KI2(X),KI3(X) ARE CALCULATED AND USED IN FORWARD +C RECURSION TO DERIVE KIN(X),N=4,5,...,10 +C +C RATIONAL POLYNOMIAL APPROXIMATIONS TO THE BICKLEY FUNCTIONS WITH A +C MINIMUM ACCURACY OF 15D WERE OBTAINED FROM "RATIONAL CHEBYSHEV +C APPROXIMATIONS TO THE BICKLEY FUNCTIONS KIN(X)",AECL- AND +C "RATIONAL CHEBYSHEV APPROXIMATIONS TO THE BICKLEY FUNCTION KI3(X), +C X \ 6",AECL-5820. +C +C X = 0. KIN(X) ,N=1,2,...,10 IS APPROXIMATED BY CONSTANTS. +C +C 0 < X < 1. KIN(X),N = 1,2,3 IS APPROXIMATED BY +C R(X) + X**N * ALOG(X) * S(X**2) +C WHERE R AND S ARE RATIONAL POLYNOMIALS IN X AND X**2 RESPECTIVELY. +C +C 1 @ X < 6. KIN(X),N=1,2,3 IS APPROXIMATED BY +C EXP(-X) * R(1. / X) ) / SQRT(X) +C WHERE R IS A RATIONAL POLYNOMIAL IN (1. / X) +C +C 6 @ X < 673.5 KIN(X),N = 8,9,10 IS APPROXIMATED BY +C EXP(-X) * R(1. / X) ) / SQRT(X) +C WHERE R IS A RATIONAL POLYNOMIAL IN (1. / X) +C +C X \ 673.5 KIN(X),1=1,10 IS APPROXIMATED BY ZERO +C +C +C WRITTEN BY P.CHRISTIE, MARCH,1977. +C +C TAKEN FROM *AELIB* LIBRARY (SUBROUTINE NAME: KIN) +C MODIFY BY R.ROY (JULY 1994) IN DOUBLE PRECISION +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION AKIN(10),LNX + SAVE +C + DATA R1P01,R1P11/-.3916967515498982D+02 , .1501664584981108D+03 / + DATA R1P21,R1P31/ .1531257133183402D+02 , .1398682937631850D+02 / + DATA R1P41,R1P51/ .5454840912170553D+00 , .5720051721276178D+00 / + DATA R1P61,R1P71/ .8766262885587739D-02 , .1001220446004980D-01 / + DATA R1P81,R1P91/ .5167460909383400D-04 , .7945473334662959D-04 / + DATA R1Q01,R1Q11/-.1193155300614385D+03 , .1219596245756669D+01 / + DATA S1P01,S1P11/ .1752373600092810D+05 , .1234654843555450D+04 / + DATA S1P21,S1P31/ .3695696751512241D+02 , .4646979722852471D+00 / + DATA S1P41 / .2337898258663651D-02 / + DATA S1Q01,S1Q11/ .1752373600092810D+05 ,-.2256564898552151D+03 / + DATA R2P01,R2P11/ .1833164538368226D+02 , .2427580524508585D+03 / + DATA R2P21,R2P31/ .1059016416894119D+04 , .1868734192859498D+04 / + DATA R2P41,R2P51/ .1326511766009986D+04 , .3272001530672078D+03 / + DATA R2P61 / .1822929159877549D+02 / + DATA R2Q01,R2Q11/ .1462653804563246D+02 , .2028344160151355D+03 / + DATA R2Q21,R2Q31/ .9570056876282360D+03 , .1922624187690926D+04 / + DATA R2Q41,R2Q51/ .1687760486772990D+04 , .5952592332227032D+03 / + DATA R2Q61 / .6590511376539962D+02 / + DATA R1P02,R1P12/ .4811961706232723D+03 , .1403058999999999D-10 / + DATA R1P22,R1P32/ .1693807200769639D+04 , .7521727532834893D+02 / + DATA R1P42,R1P52/ .4905564077627560D+02 , .9084569646859357D+00 / + DATA R1P62,R1P72/ .1190096804348251D+01 ,-.9999999999999957D-15 / + DATA R1P82 / .1086764750096697D-01 / + DATA R1Q02,R1Q12/ .1810502008060146D+04 ,-.7855291318496802D+02 / + DATA R1Q22 /-.1893578319929816D+02 / + DATA S1P02 /-.1520774316867189D+09 / + DATA S1Q02,S1Q12/ .3041548633734379D+09 ,-.1267311930720872D+08 / + DATA S1Q22,S1Q32/ .2112186548895240D+06 ,-.3143123637802091D+03 / + DATA S1Q42 /-.5631701819761997D+02 / + DATA R2P02,R2P12/ .5766817227841408D+00 , .9534267279889207D+01 / + DATA R2P22,R2P32/ .5320941946830476D+02 , .1244041140268300D+03 / + DATA R2P42,R2P52/ .1239740741934670D+03 , .4801733781249936D+02 / + DATA R2P62,R2P72/ .5596498537189973D+01 , .8407469297501269D-01 / + DATA R2Q02,R2Q12/ .4601255143693006D+00 , .8124881079392082D+01 / + DATA R2Q22,R2Q32/ .5035544525458363D+02 , .1383006201574071D+03 / + DATA R2Q42,R2Q52/ .1754089481769652D+03 , .9747773947009136D+02 / + DATA R2Q62 / .2014290370371339D+02 / + DATA R1P03,R1P13/-.7043581454636306D+06 , .1269499275481224D+07 / + DATA R1P23,R1P33/-.3790509999999980D-08 , .1095667013274141D+07 / + DATA R1P43 / .1173330390873767D+05 / + DATA R1Q03,R1Q13/-.2961415636470914D+07 , .2053835980116203D+06 / + DATA R1Q23,R1Q33/ .6077621585261822D+05 ,-.3942586515380026D+04 / + DATA R1Q43,R1Q53/-.1335161914247710D+03 ,-.1755175839841900D+02 / + DATA R1Q63 /-.5812262590904993D+01 / + DATA S1P03,S1P13/ .3027965765686327D+04 , .3721363059831219D+02 / + DATA S1P23,S1P33/ .5562992588150486D+00 , .2631126488553487D-02 / + DATA S1Q03,S1Q13/ .1816779459411791D+05 ,-.2309130812632629D+03 / + DATA R2P03,R2P13/ .3057730071278506D+00 , .5484114159179143D+01 / + DATA R2P23,R2P33/ .3295675793097689D+02 , .8221915520880930D+02 / + DATA R2P43,R2P53/ .8663638447767516D+02 , .3523089103388543D+02 / + DATA R2P63,R2P73/ .4296855364707056D+01 , .6753131438170179D-01 / + DATA R2Q03,R2Q13/ .2439716682658748D+00 , .4772136519722949D+01 / + DATA R2Q23,R2Q33/ .3279841354751966D+02 , .9980505157913694D+02 / + DATA R2Q43,R2Q53/ .1397165642636965D+03 , .8502251629078864D+02 / + DATA R2Q63 / .1898628899818902D+02 / + DATA R1P08,R1P18/ .2613746296365794D-04 , .1418798411613728D-02 / + DATA R1P28,R1P38/ .2815600768166693D-01 , .2548459851246907D+00 / + DATA R1P48,R1P58/ .1072628589602992D+01 , .1911501312353472D+01 / + DATA R1P68,R1P78/ .1112575911492456D+01 , .8986422681366424D-01 / + DATA R1Q08,R1Q18/ .2085467815725935D-04 , .1218062894916834D-02 / + DATA R1Q28,R1Q38/ .2689392859262307D-01 , .2845497743872052D+00 / + DATA R1Q48,R1Q58/ .1507878566796656D+01 , .3799408842694803D+01 / + DATA R1Q68 / .3846344279573060D+01 / + DATA R1P09,R1P19/ .4238334538408917D-04 , .2673933491122202D-02 / + DATA R1P29,R1P39/ .6307055224810387D-01 , .7008898871037985D+00 / + DATA R1P49,R1P59/ .3808588292608732D+01 , .9546586415461775D+01 / + DATA R1P69,R1P79/ .9312166436472808D+01 , .2271732886275686D+01 / + DATA R1Q09,R1Q19/ .3381701691714022D-04 , .2289893952421851D-02 / + DATA R1Q29,R1Q39/ .5971301111405558D-01 , .7653242147414652D+00 / + DATA R1Q49,R1Q59/ .5098663790807535D+01 , .1715435708724829D+02 / + DATA R1Q69,R1Q79/ .2599209729530514D+02 , .1346934010366220D+02 / + DATA R1P010,R1P110/.2984857391503590D-04, .1966652996666221D-02 / + DATA R1P210,R1P310/.4842493199976428D-01, .5612690964007783D+00 / + DATA R1P410,R1P510/.3176720369338028D+01, .8279846050989022D+01 / + DATA R1P610,R1P710/.8380471295924849D+01, .2115457456609434D+01 / + DATA R1Q010,R1Q110/.2381571628879027D-04, .1691217608476688D-02 / + DATA R1Q210,R1Q310/.4627626853651856D-01, .6224227393849020D+00 / + DATA R1Q410,R1Q510/.4348767092235221D+01, .1531699714433142D+02 / + DATA R1Q610,R1Q710/.2421477559533582D+02, .1303324507927971D+02 / +C +C + IF (X.LT.0.D0) GO TO 400 +C + IF (X.EQ.0.D0) GO TO 300 + IF (X.LT.1.D0) GO TO 200 + IF (X.GE.673.5D0) GO TO 110 + SQRTX = SQRT(X) + EXPX = EXP(-X) + XREC = 1.D0/ X + IF (X.LT.6.D0) GO TO 210 +C +C +C 6 @ X < 673.5 CALCULATE KI(X),KI9(X),KI10(X) +C + AKIN(10) =(((((((((R1P710 * XREC + R1P610) * XREC + R1P510) * XREC + ,+ R1P410) * XREC + R1P310) * XREC + R1P210) * XREC + R1P110) * + ,XREC + R1P010) / ((((((((XREC + R1Q710) * XREC + R1Q610) + ,* XREC + R1Q510) * XREC + R1Q410) * XREC + R1Q310) * XREC + R1Q210 + ,) * XREC + R1Q110) * XREC + R1Q010) ) / SQRTX) * EXPX +C + AKIN(9) =(((((((((R1P79 * XREC + R1P69) * XREC + R1P59) * XREC + ,+ R1P49) * XREC + R1P39) * XREC + R1P29) * XREC + R1P19) * XREC + ,+ R1P09) / ((((((((XREC + R1Q79) * XREC + R1Q69) * XREC + ,+ R1Q59) * XREC + R1Q49) * XREC + R1Q39) * XREC + R1Q29) * XREC + ,+ R1Q19) * XREC + R1Q09) ) / SQRTX) * EXPX +C + AKIN(8) =(((((((((R1P78 * XREC + R1P68) * XREC + R1P58) * XREC + ,+ R1P48) * XREC + R1P38) * XREC + R1P28) * XREC + R1P18) * XREC + ,+ R1P08) / (((((((XREC + R1Q68) * XREC + R1Q58) * XREC + ,+ R1Q48) * XREC + R1Q38) * XREC + R1Q28) * XREC + R1Q18) * XREC + ,+ R1Q08) ) / SQRTX) * EXPX +C +C BACKWARD RECURSION +C + DO 100 I = 1,7 + J = 8 - I + AKIN(J) = ((DBLE(J + 2) * AKIN(J + 3)) - (DBLE(J + 1) + , * AKIN(J + 1))) / X + AKIN(J + 2) + 100 CONTINUE + RETURN +C +C +C X \ 673.5 AUTOMATICALLY SET AKIN(I),I=1,10 EQUAL TO ZERO +C + 110 DO 120 I = 1,10 + AKIN(I)=0.D0 + 120 CONTINUE + RETURN +C +C +C 0 < X < 1. CALCULATE KI1(X),KI2(X),KI3(X) +C + 200 XSQ = X*X + LNX = LOG(X) + XI1 = X - .91169076342161D0 + XI2 = X - .2451000192866D0 + XI3 = X - 1.D0 + XI4 = X - .68448452306295D0 +C + AKIN(1) = (((((((((R1P91 * X + R1P81) * X + R1P71) * X + R1P61) + ,* X + R1P51) * X + R1P41) * X + R1P31) * X + R1P21) * X + R1P11) + ,*XI3 + R1P01) / ((X + R1Q11) * XI3 + R1Q01) + (X * LNX * ((((S1P41 + ,* XSQ + S1P31) * XSQ + S1P21) * XSQ + S1P11) * XSQ + S1P01) / + ,((XSQ + S1Q11) * XSQ + S1Q01)) +C + AKIN(2) = ((((R1P12 * XI1 + R1P02) + ((((R1P52 * X + R1P42) * X + ,+ R1P32) * X + R1P22) + (((R1P82 * XI2 + R1P72) * XI2 + R1P62) + ,* (X**4))) * (XI1 * XI1)) / (R1Q02 + ((( XI3 + R1Q22) * X + ,+ R1Q12) * XI3))) + (XSQ * LNX * ((S1P02) / ((((( XSQ + ,+ S1Q42) * XSQ + S1Q32) * XSQ + S1Q22) * XSQ + S1Q12) * XSQ + ,+ S1Q02)))) +C + AKIN(3) = (((((R1P43 * X + R1P33) * XI4 + R1P23) * XI4 + R1P13) + ,* XI3 + R1P03) / (((((((XI3 + R1Q63) * X + R1Q53) * X + R1Q43) + ,* X + R1Q33) * XI3 + R1Q23) * X + R1Q13) * XI3 + R1Q03)) + (X**3 + ,* LNX * ((((S1P33 * XSQ + S1P23) * XSQ + S1P13) * XSQ + S1P03) / + ,((XSQ + S1Q13) * XSQ + S1Q03))) +C + GO TO 220 +C +C +C 1 @ X < 6. CALCULATE KI1(X),KI2(X),KI3(X) +C + 210 AKIN(1) = (((((((R2P61 * XREC + R2P51) * XREC + R2P41) * XREC + ,+ R2P31) * XREC + R2P21) * XREC + R2P11) * XREC + R2P01) * EXPX) / + ,((((((((XREC + R2Q61) *XREC + R2Q51) * XREC + R2Q41) * XREC + ,+ R2Q31) * XREC + R2Q21) * XREC + R2Q11) * XREC + R2Q01) * SQRTX) +C + AKIN(2) = ((((((((R2P72 * XREC + R2P62) * XREC + R2P52) * XREC + ,+ R2P42) * XREC + R2P32) * XREC + R2P22) * XREC + R2P12) * XREC + ,+ R2P02) * EXPX) / ((((((((XREC + R2Q62) * XREC + R2Q52) * XREC + ,+ R2Q42) * XREC + R2Q32) * XREC + R2Q22) * XREC + R2Q12) * XREC + ,+ R2Q02) * SQRTX) +C + AKIN(3) = ((((((((R2P73 * XREC + R2P63) * XREC + R2P53) * XREC + ,+ R2P43) * XREC + R2P33) * XREC + R2P23) * XREC + R2P13) * XREC + ,+ R2P03) * EXPX) / ((((((((XREC + R2Q63) * XREC + R2Q53) * XREC + ,+ R2Q43) * XREC + R2Q33) * XREC + R2Q23) * XREC + R2Q13) * XREC + ,+ R2Q03) * SQRTX) +C +C FORWARD RECURSION +C + 220 DO 230 I = 1,7 + J = I + 3 + AKIN(J) = (AKIN(J - 3) - AKIN(J - 1)) * X / DBLE(J - 1) + , + DBLE(J - 2) * AKIN(J - 2) / DBLE(J - 1) + 230 CONTINUE + RETURN +C +C +C X = 0. +C + 300 AKIN(1) = 1.57079632679489D0 + AKIN(2) = 1.D0 + AKIN(3) = .78539816339745D0 + AKIN(4) = .66666666666667D0 + AKIN(5) = .58904862254808D0 + AKIN(6) = .53333333333333D0 + AKIN(7) = .49087385212340D0 + AKIN(8) = .45714285714286D0 + AKIN(9) = .42951462060798D0 + AKIN(10)= .40634920634920D0 + RETURN + 400 CALL XABORT('AKIN10: ILLEGAL ARGUMENT FOR BICKLEY FUNCTIONS') + END diff --git a/Utilib/src/AL1EIG.f b/Utilib/src/AL1EIG.f new file mode 100644 index 0000000..be699d8 --- /dev/null +++ b/Utilib/src/AL1EIG.f @@ -0,0 +1,67 @@ +*DECK AL1EIG + SUBROUTINE AL1EIG(N,A,EPSOUT,MAXOUT,ITER,EVECT,EVAL,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the fundamental eigenvalue and corresponding eigenvector of +* equation (A-EVAL)*EVECT=0 using the power method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of unknowns +* A coefficient matrix +* EPSOUT convergence epsilon for the power method +* MAXOUT maximum number of iterations for the power method +* EVECT initial estimate +* IPRINT print parameter +* +*Parameters: output +* ITER number of iterations +* EVECT corresponding eigenvector +* EVAL fondamental eigenvalue +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MAXOUT,ITER,IPRINT + REAL A(N,N),EPSOUT,EVECT(N),EVAL +*---- +* LOCAL VARIABLES +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: GAR +*---- +* POWER METHOD +*---- + EVECT(:N)=1.0 + ITER=0; + ALLOCATE(GAR(N)) + DO + ITER=ITER+1 + IF (ITER > MAXOUT) CALL XABORT('AL1EIG: UNABLE TO CONVERGE.') + GAR(:)=EVECT(:) + EVECT(:)=MATMUL(A(:,:),EVECT(:)) + EVAL=SQRT(DOT_PRODUCT(EVECT(:),EVECT(:))) + EVECT(:)=EVECT(:)/EVAL + ERR1=MAXVAL(ABS(EVECT)) + ERR2=MAXVAL(ABS(GAR(:)-EVECT(:))) + IF(IPRINT.GT.1) THEN + IF(MOD(ITER,5) == 1) WRITE(6,10) ITER,EVAL,ERR2 + ENDIF + IF(ERR2 <= ERR1*EPSOUT) EXIT + ENDDO + IF(IPRINT.GT.1) WRITE(6,10) ITER,EVAL,ERR2 + DEALLOCATE(GAR) + RETURN + 10 FORMAT(14H AL1EIG: ITER=,I6,6H EVAL=,1P,E12.5,7H ERROR=,E11.4) + END diff --git a/Utilib/src/AL1EIGD.f b/Utilib/src/AL1EIGD.f new file mode 100644 index 0000000..4e3a411 --- /dev/null +++ b/Utilib/src/AL1EIGD.f @@ -0,0 +1,68 @@ +*DECK AL1EIGD + SUBROUTINE AL1EIGD(N,A,EPSOUT,MAXOUT,ITER,EVECT,EVAL,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the fundamental eigenvalue and corresponding eigenvector of +* equation (A-EVAL)*EVECT=0 using the power method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of unknowns +* A coefficient matrix +* EPSOUT convergence epsilon for the power method +* MAXOUT maximum number of iterations for the power method +* EVECT initial estimate +* IPRINT print parameter +* +*Parameters: output +* ITER number of iterations +* EVECT corresponding eigenvector +* EVAL fondamental eigenvalue +* +*----------------------------------------------------------------------- +* + IMPLICIT REAL*8(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MAXOUT,ITER,IPRINT + REAL(KIND=8) A(N,N),EPSOUT,EVECT(N),EVAL +*---- +* LOCAL VARIABLES +*---- + REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: GAR +*---- +* POWER METHOD +*---- + EVECT(:N)=1.D0 + ITER=0; + ALLOCATE(GAR(N)) + DO + ITER=ITER+1 + IF (ITER > MAXOUT) CALL XABORT('AL1EIGD: UNABLE TO CONVERGE.') + GAR(:)=EVECT(:) + EVECT(:)=MATMUL(A(:,:),EVECT(:)) + EVAL=SQRT(DOT_PRODUCT(EVECT(:),EVECT(:))) + EVECT(:)=EVECT(:)/EVAL + ERR1=MAXVAL(ABS(EVECT)) + ERR2=MAXVAL(ABS(GAR(:)-EVECT(:))) + IF(IPRINT.GT.1) THEN + IF(MOD(ITER,5) == 1) WRITE(6,10) ITER,EVAL,ERR2 + ENDIF + IF(ERR2 <= ERR1*EPSOUT) EXIT + ENDDO + IF(IPRINT.GT.1) WRITE(6,10) ITER,EVAL,ERR2 + DEALLOCATE(GAR) + RETURN + 10 FORMAT(15H AL1EIGD: ITER=,I6,6H EVAL=,1P,E13.6,7H ERROR=,E11.4) + END diff --git a/Utilib/src/ALCACT.f b/Utilib/src/ALCACT.f new file mode 100644 index 0000000..9318176 --- /dev/null +++ b/Utilib/src/ALCACT.f @@ -0,0 +1,164 @@ +*DECK ALCACT + SUBROUTINE ALCACT(LCACT,NG,XG,WG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* set the weights and base points for the different polar quadrature: +* - "Cactus" (Halsall) +* - "optimized" (Leonard and extension by Le Tellier) +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Reference: +* A. Leonard and C.T. Mc Daniel, "Optimal polar angles and weights for +* the characteristic method", Trans. Am. Nucl. Soc., 73, 172 (1995). +* +*Parameters: input +* LCACT type of quadrature (=1,2: values used by Halsall in +* Cactus (1980); =3: values proposed by Mc Daniel ng=2 only, +* extended to 3 and 4 with the same approach by R. Le Tellier +* in 06/2005) +* NG number of weights/base points. +* +*Parameters: output +* XG base points. +* WG weights. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LCACT,NG + REAL XG(NG),WG(NG) +*---- +* LOCAL VARIABLES +*---- + INTEGER IG + DOUBLE PRECISION PI, PHIM, PHIP, DELPHI, WTEST, XTEST, YTEST, + > ZTEST, ZERO, ONE, HALF, QUART + PARAMETER( PI=3.14159265358979D0, ZERO=0.D0, ONE=1.D0, + > HALF=0.5D0, QUART=0.25D0 ) +* For "Optimized" Quadrature + INTEGER I, I2, I3, I4, I5, IDEP, IFIN + PARAMETER ( I2= 1, I3= 3, I4= 6, I5= 10) + REAL XOP0(I5-1), WOP0(I5-1) ! Quadrature which minimizes the error on Ki2 without constraints. + REAL XOP1(I5-1), WOP1(I5-1) ! Quadrature which minimizes the error on Ki2 with P1 constraints. + REAL XGOP(I5-1), WGOP(I5-1) ! Gauss optimized quadrature. + SAVE XOP0, WOP0, XOP1, WOP1, XGOP, WGOP +* NG=2 + DATA (XOP0(I),I=I2,I3-1) / 0.273658, 0.865714/ + DATA (WOP0(I),I=I2,I3-1) / 0.139473, 0.860527/ + DATA (XOP1(I),I=I2,I3-1) / 0.340183, 0.894215/ + DATA (WOP1(I),I=I2,I3-1) / 0.194406, 0.805594/ + DATA (XGOP(I),I=I2,I3-1) / 0.399374, 0.914448/ + DATA (WGOP(I),I=I2,I3-1) / 0.250547, 0.749453/ +* NG=3 + DATA (XOP0(I),I=I3,I4-1) / 0.891439, 0.395534, 0.099812/ + DATA (WOP0(I),I=I3,I4-1) / 0.793820, 0.188560, 0.017620/ + DATA (XOP1(I),I=I3,I4-1) / 0.131209, 0.478170, 0.920079/ + DATA (WOP1(I),I=I3,I4-1) / 0.029991, 0.250860, 0.719149/ + DATA (XGOP(I),I=I3,I4-1) / 0.231156, 0.639973, 0.954497/ + DATA (WGOP(I),I=I3,I4-1) / 0.085302, 0.341456, 0.573242/ +* NG=4 + DATA (XOP0(I),I=I4,I5-1) / 0.464167, 0.908274, 0.166004, 0.042181/ + DATA (WOP0(I),I=I4,I5-1) / 0.218331, 0.746430, 0.032141, 0.003098/ + DATA (XOP1(I),I=I4,I5-1) / 0.054819, 0.212313, 0.546065, 0.932318/ + DATA (WOP1(I),I=I4,I5-1) / 0.005225, 0.051270, 0.272789, 0.670716/ + DATA (XGOP(I),I=I4,I5-1) / 0.152641, 0.450820, 0.769181, 0.972320/ + DATA (WGOP(I),I=I4,I5-1) / 0.037508, 0.167623, 0.338496, 0.456373/ +! DATA (XGOP(I),I=I5,I6-1) / 0.159153, 0.450941, 0.724750, 0.868405, +! 1 0.980414/ +! DATA (WGOP(I),I=I5,I6-1) / 0.039977, 0.156595, 0.220669, 0.204037, +! 1 0.378722/ +* + IF( LCACT.EQ.1 )THEN +*--- +* CACTUS 1: +*--- +* Equal weight quadrature + DELPHI= ONE/DBLE(NG) + PHIM = ZERO + XTEST = ZERO + DO 10 IG= 1, NG + PHIP = DBLE(IG) * DELPHI + WTEST = PHIP - PHIM + WG(IG)= REAL( WTEST ) + IF(IG.EQ.NG) THEN + YTEST = PI/2.0 + ELSE + YTEST = SQRT(ONE - PHIP * PHIP) * PHIP + ASIN(PHIP) + ENDIF + ZTEST = HALF * (YTEST - XTEST) / WTEST + XG(IG)= REAL( SQRT(ONE - ZTEST*ZTEST) ) + PHIM = PHIP + XTEST = YTEST + 10 CONTINUE + ELSEIF( LCACT.EQ.2 )THEN +*--- +* CACTUS 2: +*--- +* Uniformly distributed angle quadrature + DELPHI= PI/DBLE(2*NG) + PHIM = ZERO + DO 20 IG= 1, NG + PHIP = DBLE(IG) * DELPHI + WTEST = SIN(PHIP) - SIN(PHIM) + WG(IG)= REAL( WTEST ) + XTEST = HALF * (PHIP - PHIM) + YTEST = QUART * (SIN(PHIP+PHIP) - SIN(PHIM+PHIM)) + ZTEST = (XTEST + YTEST) / WTEST + XG(IG)= REAL( SQRT(ONE - ZTEST*ZTEST) ) + PHIM= PHIP + 20 CONTINUE + ELSEIF(( LCACT.GE.3 ).AND.( LCACT.LE.5 ))THEN +*--- +* OPTIMIZED: +*--- + IDEP=0 + IFIN=0 + IF( NG.EQ.2 ) THEN + IDEP=I2 + IFIN=I3-1 + ELSE IF( NG.EQ.3 ) THEN + IDEP=I3 + IFIN=I4-1 + ELSE IF( NG.EQ.4 ) THEN + IDEP=I4 + IFIN=I5-1 + ELSE + CALL XABORT('ALCACT: LCACA=3 => NG= 2, 3 OR 4') + ENDIF + IF (LCACT.EQ.3) THEN +* Quadrature which minimizes the error on Ki2 without constraints. + DO 30 IG= IDEP, IFIN + XG(IG-IDEP+1)= REAL(SQRT(ONE - XOP0(IG)*XOP0(IG))) + WG(IG-IDEP+1)= WOP0(IG) + 30 CONTINUE + ELSEIF (LCACT.EQ.4) THEN +* Quadrature which minimizes the error on Ki2 with P1 constraints. + DO 40 IG= IDEP, IFIN + XG(IG-IDEP+1)= REAL(SQRT(ONE - XOP1(IG)*XOP1(IG))) + WG(IG-IDEP+1)= WOP1(IG) + 40 CONTINUE + ELSEIF (LCACT.EQ.5) THEN +* Gauss optimized quadrature. + DO 50 IG= IDEP, IFIN + XG(IG-IDEP+1)= REAL(SQRT(ONE - XGOP(IG)*XGOP(IG))) + WG(IG-IDEP+1)= WGOP(IG) + 50 CONTINUE + ENDIF + ELSE + CALL XABORT('ALCACT: *LCACT* IN [1,5]') + ENDIF + RETURN + END diff --git a/Utilib/src/ALDDLF.f b/Utilib/src/ALDDLF.f new file mode 100644 index 0000000..f690da7 --- /dev/null +++ b/Utilib/src/ALDDLF.f @@ -0,0 +1,71 @@ +*DECK ALDDLF + SUBROUTINE ALDDLF (L4,ASS,MU1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* in-place L-D-L(T) factorization of a symmetric positive definite +* matrix in compressed diagonal storage mode. +* Double precision version. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* ASS coefficient matrix in compressed diagonal storage mode. +* A(I,J)=ASS(MU1(I)-I+J) if J.le.I and J.gt.I+MU1(I-1)-MU1(I) +* =A(J,I) if I.lt.J +* =0.0 else +* DIMENSION ASS(MU1(L4)-MU1(1)+1) +* MU1 position of each diagonal element in vector ASS. +* +*Parameters: output +* ASS LDL(T) factors. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4) + DOUBLE PRECISION ASS(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION S,R +* + ASS(MU1(1))=1.0D0/ASS(MU1(1)) + IF (L4.EQ.1) RETURN + DO 10 K=2,L4 + K1=MU1(K)-K + KM=MU1(K-1)+1-K1 + IF(KM+1.GT.K) GO TO 7 + DO 2 I=KM+1,K-1 + R=ASS(K1+I) + ASS(K1+I)=0.0D0 + S=0.0D0 + I1=MU1(I)-I + IM=MU1(I-1)+1-I1 + DO 5 J=MAX0(IM,KM),I + S=S+ASS(K1+J)*ASS(I1+J) + 5 CONTINUE + ASS(K1+I)=R-S + 2 CONTINUE + S=0.0D0 + DO 6 I=KM,K-1 + R=ASS(K1+I) + ASS(K1+I)=R*ASS(MU1(I)) + S=S+R*ASS(K1+I) + 6 CONTINUE + ASS(MU1(K))=ASS(MU1(K))-S + 7 ASS(MU1(K))=1.0D0/ASS(MU1(K)) + 10 CONTINUE + RETURN + END diff --git a/Utilib/src/ALDDLM.f b/Utilib/src/ALDDLM.f new file mode 100644 index 0000000..f0bf4ba --- /dev/null +++ b/Utilib/src/ALDDLM.f @@ -0,0 +1,75 @@ +*DECK ALDDLM + SUBROUTINE ALDDLM (L4,ASS,VEC,Z,MU1,ITY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* multiplication of a symmetric matrix in compressed diagonal storage +* mode by a vector. +* Double precision version. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* ASS coefficient matrix in compressed diagonal storage mode. +* DIMENSION ASS(MU1(L4)) +* VEC vector to multiply. +* Z vector that will be added to the result if ITY=2. +* MU1 position of each diagonal element in vector ASS. +* ITY type of multiplication (ITY=1: Z=ASS*VEC; +* ITY=2: Z=Z+(ASS-DIAG(ASS))*VEC). +* +*Parameters: output +* Z solution of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4),ITY + DOUBLE PRECISION ASS(*),VEC(L4),Z(L4) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION ZK +* + GO TO (10,60),ITY +* +* CALCULATION OF Z=ASS*VEC. + 10 Z(1)=ASS(MU1(1))*VEC(1) + I1=MU1(1)+1 + DO 50 K=2,L4 + I2=MU1(K) + KEY1=I2-K + ZK=0.0D0 + DO 30 L=I1-I2+K,K-1 + ZK=ZK+ASS(KEY1+L)*VEC(L) + Z(L)=Z(L)+ASS(KEY1+L)*VEC(K) + 30 CONTINUE + Z(K)=ZK+ASS(KEY1+K)*VEC(K) + I1=I2+1 + 50 CONTINUE + RETURN +* +* CALCULATION OF Z=Z+(ASS-DIAG(ASS))*VEC. + 60 I1=MU1(1)+1 + DO 80 K=2,L4 + I2=MU1(K) + KEY1=I2-K + DO 70 L=I1-I2+K,K-1 + Z(K)=Z(K)+ASS(KEY1+L)*VEC(L) + Z(L)=Z(L)+ASS(KEY1+L)*VEC(K) + 70 CONTINUE + I1=I2+1 + 80 CONTINUE + RETURN + END diff --git a/Utilib/src/ALDDLS.f b/Utilib/src/ALDDLS.f new file mode 100644 index 0000000..0afada3 --- /dev/null +++ b/Utilib/src/ALDDLS.f @@ -0,0 +1,75 @@ +*DECK ALDDLS + SUBROUTINE ALDDLS (L4,MU1,ASS,F) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solution of a symmetric linear system where the coefficient matrix +* have been factorized by a preceding call to ALLDLF. +* Double precision version. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* MU1 position of each diagonal element in vector ASS. +* ASS LDL(T) factors of the coefficient matrix in compressed +* diagonal storage mode. DIMENSION ASS(MU1(L4)-MU1(1)+1) +* F right-hand side of the linear system. +* +*Parameters: output +* F solution of the linear system. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4) + DOUBLE PRECISION ASS(*),F(L4) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION T +* + IF (L4.EQ.1) GO TO 60 + K1=MU1(1)+1 + DO 20 I=2,L4 + K2=MU1(I) + KJ=I-K2+K1 + T=-F(I) + DO 10 K=K1,K2-1 + T=T+F(KJ)*ASS(K) + KJ=KJ+1 + 10 CONTINUE + K1=K2+1 + F(I)=-T + 20 CONTINUE +C + DO 30 I=1,L4 + F(I)=F(I)*ASS(MU1(I)) + 30 CONTINUE +C + K2=MU1(L4) + DO 50 I=L4,2,-1 + T=-F(I) + K1=MU1(I-1)+1 + KJ=I-K2+K1 + DO 40 K=K1,K2-1 + F(KJ)=F(KJ)+ASS(K)*T + KJ=KJ+1 + 40 CONTINUE + K2=K1-1 + 50 CONTINUE + RETURN +C + 60 F(1)=F(1)*ASS(MU1(1)) + RETURN + END diff --git a/Utilib/src/ALDERV.f b/Utilib/src/ALDERV.f new file mode 100644 index 0000000..239a396 --- /dev/null +++ b/Utilib/src/ALDERV.f @@ -0,0 +1,81 @@ +*DECK ALDERV + SUBROUTINE ALDERV(N,X,Y) +* +*----------------------------------------------------------------------- +* +*Purpose: +* numerical derivation of an array of values using the order 4 Ceschino +* method (compatible with cubic splines). +* +*Copyright: +* Copyright (C) 1981 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of points. +* X abscissas. +* Y ordinates. +* +*Parameters: output +* Y derivatives. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N + REAL X(N),Y(N) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, DIMENSION(:,:), ALLOCATABLE :: WK +* + IF(N.LE.1) CALL XABORT('ALDERV: INVALID NUMBER OF POINTS.') + IF(N.EQ.2) GO TO 40 + ALLOCATE(WK(2,N)) + HP=1.0/(X(2)-X(1)) + WK(1,1)=HP + WK(2,1)=HP + YLAST=Y(1) + Y(1)=2.0*HP*HP*(Y(2)-Y(1)) + DO 10 I=2,N-1 + HM=HP + HP=1.0/(X(I+1)-X(I)) + WK(1,I)=2.0*(HM+HP) + WK(2,I)=HP + PMX=3.0*(HM*HM*(Y(I)-YLAST)+HP*HP*(Y(I+1)-Y(I))) + YLAST=Y(I) + Y(I)=PMX + 10 CONTINUE + HM=HP + WK(1,N)=HM + WK(2,N)=HM + Y(N)=2.0*HM*HM*(Y(N)-YLAST) +* +* FORWARD ELIMINATION. + PMX=WK(1,1) + Y(1)=Y(1)/PMX + DO 20 I=2,N + GAR=WK(2,I-1) + WK(2,I-1)=WK(2,I-1)/PMX + PMX=WK(1,I)-GAR*WK(2,I-1) + Y(I)=(Y(I)-GAR*Y(I-1))/PMX + 20 CONTINUE +* +* BACK SUBSTITUTION. + DO 30 I=N-1,1,-1 + Y(I)=Y(I)-WK(2,I)*Y(I+1) + 30 CONTINUE + DEALLOCATE(WK) + RETURN +* + 40 Y(1)=(Y(2)-Y(1))/(X(2)-X(1)) + Y(2)=Y(1) + RETURN + END diff --git a/Utilib/src/ALDFIT.f b/Utilib/src/ALDFIT.f new file mode 100644 index 0000000..2a3e89f --- /dev/null +++ b/Utilib/src/ALDFIT.f @@ -0,0 +1,109 @@ +*DECK ALDFIT + SUBROUTINE ALDFIT(N,MA,X,Y,W,PARAM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* performs linear least squares fitting to a polynomial of a specified +* order in one independent variable using the Forsythe method. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of data points i.e., number of X,Y values. +* MA integer specifying the order of the polynomial. +* X array of values of indep. variable. +* Y array of values of dependent variable. +* W array of weights. +* +*Parameters: output +* PARAM real array of coefficients of the fitted polynomial. +* PARAM(I)=coeff. of X**I. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MA + DOUBLE PRECISION X(N),Y(N),W(N),PARAM(0:MA) +*---- +* ALLOCATABLE ARRAYS +*---- + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: GAMMA,POLY,PP +* + IF(MA.GE.N) CALL XABORT('ALDFIT: UNDER-DETERMINED SYSTEM.') + AA=0.0D0 + BB=0.0D0 + CC=0.0D0 + DO 10 I=1,N + AA=AA+W(I)*X(I) + BB=BB+W(I)*Y(I) + CC=CC+W(I) + 10 CONTINUE + PARAM(0)=BB/CC + IF(MA.EQ.0) RETURN + ALLOCATE(GAMMA(MA,3),POLY(N,0:2),PP(0:MA,0:2)) + POLY(:N,0)=1.0D0 + GAMMA(1,1)=AA/CC + GAMMA(1,2)=0.0D0 + AA=0.0D0 + BB=0.0D0 + DO 20 I=1,N + POLY(I,1)=X(I)-GAMMA(1,1) + AA=AA+W(I)*POLY(I,1)*Y(I) + BB=BB+W(I)*POLY(I,1)**2 + 20 CONTINUE + GAMMA(1,3)=AA/BB + DO 50 J=2,MA + AA=0.0D0 + BB=0.0D0 + CC=0.0D0 + DD=0.0D0 + DO 30 I=1,N + AA=AA+W(I)*X(I)*POLY(I,MOD(J-1,3))**2 + BB=BB+W(I)*POLY(I,MOD(J-1,3))**2 + CC=CC+W(I)*X(I)*POLY(I,MOD(J-1,3))*POLY(I,MOD(J-2,3)) + DD=DD+W(I)*POLY(I,MOD(J-2,3))**2 + 30 CONTINUE + GAMMA(J,1)=AA/BB + GAMMA(J,2)=CC/DD + AA=0.0D0 + BB=0.0D0 + DO 40 I=1,N + POLY(I,MOD(J,3))=(X(I)-GAMMA(J,1))*POLY(I,MOD(J-1,3))-GAMMA(J,2)* + 1 POLY(I,MOD(J-2,3)) + AA=AA+W(I)*POLY(I,MOD(J,3))*Y(I) + BB=BB+W(I)*POLY(I,MOD(J,3))**2 + 40 CONTINUE + GAMMA(J,3)=AA/BB + 50 CONTINUE +* + DO 60 I=1,MA + PP(I,0)=0.0D0 + PARAM(I)=0.0D0 + 60 CONTINUE + PP(0,0)=1.0D0 + DO 90 J=1,MA + DO 70 I=0,MA + PP(I,MOD(J,3))=0.0D0 + 70 CONTINUE + DO 80 I=0,J + IF(I.LT.J) PP(I+1,MOD(J,3))=PP(I,MOD(J-1,3)) + PP(I,MOD(J,3))=PP(I,MOD(J,3))-PP(I,MOD(J-1,3))*GAMMA(J,1) + IF(J.GT.1) PP(I,MOD(J,3))=PP(I,MOD(J,3))-PP(I,MOD(J-2,3))* + 1 GAMMA(J,2) + PARAM(I)=PARAM(I)+PP(I,MOD(J,3))*GAMMA(J,3) + 80 CONTINUE + 90 CONTINUE + DEALLOCATE(GAMMA,POLY,PP) + RETURN + END diff --git a/Utilib/src/ALEIGD.f b/Utilib/src/ALEIGD.f new file mode 100644 index 0000000..350387f --- /dev/null +++ b/Utilib/src/ALEIGD.f @@ -0,0 +1,97 @@ +*DECK ALEIGD + SUBROUTINE ALEIGD (A,B,N,EVAL,EVECT,EPS,ITER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* find the fondamental eigenvalue and corresponding eigenvector of +* equation (A-EVAL*B)*EVECT=0 using the inverse power method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* A first coefficient matrix +* B second coefficient matrix +* N number of unknowns +* EVECT initial estimate +* EPS2 stopping criterion +* +*Parameters: output +* EVAL fondamental eigenvalue +* EVECT corresponding eigenvector +* ITER number of iterations +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,ITER + DOUBLE PRECISION A(N,N),B(N,N),EVAL,EVECT(N),EPS +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MMAX=1000) + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: GAR +*---- +* COMPUTE THE ITERATIVE MATRIX +*---- + CALL ALINVD (N,A,N,IER) + IF(IER.EQ.1) CALL XABORT('ALEIGD: SINGULAR MATRIX.') + ALLOCATE(GAR(N)) + DO 30 I=1,N + DO 10 J=1,N + GAR(J)=A(I,J) +10 CONTINUE + DO 25 J=1,N + A(I,J)=0.0D0 + DO 20 K=1,N + A(I,J)=A(I,J)+GAR(K)*B(K,J) +20 CONTINUE +25 CONTINUE +30 CONTINUE +*---- +* PERFORM POWER ITERATIONS +*---- + TEST=0.0D0 + ITER=0 + EVAL=0.0D0 +40 ITER=ITER+1 + IF(ITER.GT.MMAX) CALL XABORT('ALEIGD: UNABLE TO CONVERGE(1).') + S1=0.0D0 + S2=0.0D0 + DO 60 I=1,N + GAR(I)=0.0D0 + DO 50 J=1,N + GAR(I)=GAR(I)+A(I,J)*EVECT(J) +50 CONTINUE + S1=S1+GAR(I)*EVECT(I) + S2=S2+GAR(I)**2 +60 CONTINUE + IF(S2.EQ.0.0D0) CALL XABORT('ALEIGD: DIVIDE CHECK.') + ZZ=ABS(EVAL-S1/S2) + EVAL=S1/S2 + ERR1=0.0D0 + ERR2=0.0D0 + DO 70 I=1,N + ERR1=MAX(ERR1,ABS(GAR(I)*EVAL)) + ERR2=MAX(ERR2,ABS(GAR(I)*EVAL-EVECT(I))) + EVECT(I)=GAR(I)*EVAL +70 CONTINUE + IF((ZZ.LE.EPS).AND.(ERR2.LE.ERR1*EPS)) THEN + DEALLOCATE(GAR) + RETURN + ENDIF + IF(ITER.EQ.1) TEST=ZZ + IF((ITER.GE.10).AND.(ZZ.GT.TEST)) CALL XABORT('ALEIGD: UNABLE TO' + 1 //' CONVERGE(2).') + GO TO 40 + END diff --git a/Utilib/src/ALGJP.f b/Utilib/src/ALGJP.f new file mode 100644 index 0000000..b78db9f --- /dev/null +++ b/Utilib/src/ALGJP.f @@ -0,0 +1,131 @@ +*DECK ALGJP + SUBROUTINE ALGJP(NGPT,ZJKSI,WJKSI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* returns Gauss-Jacobi integration points and weights for integration +* between 0.0 and 1.0 to the order specified +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Reference: +* integral of X F(X) DX , from 0.0 to 1.0 is given by summ from i=1 to +* NGPT of F(ZJKSI(I))*WJKSI(I) +* the points ZGKSI and weights WJKSI are generated according +* to the technique described in Handbook of mathematical functions +* M. Abramowitz and I. Stegun, Dover Publication Inc. (1972). +* +*Parameters: input +* NGPT number of gauss-jacobi points +* +*Parameters: output +* ZGKSI integration points +* WGKSI integration weights +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGPT + REAL ZJKSI(NGPT),WJKSI(NGPT) +*---- +* LOCAL VARIABLES +*---- + PARAMETER ( I1= 1, I2= 2, I3= 4, I4= 7, I5=11, I6=16, + > I7=22, I8=29,IFN=36) + REAL RZKSI(IFN),RWKSI(IFN) +C N=1 + DATA (RZKSI(I),I=I1,I2-1) /0.6666666667/ + DATA (RWKSI(I),I=I1,I2-1) /0.5000000000/ +C N=2 + DATA (RZKSI(I),I=I2,I3-1) /0.3550510257,0.8449489743/ + DATA (RWKSI(I),I=I2,I3-1) /0.1819586183,0.3180413817/ +C N=3 + DATA (RZKSI(I),I=I3,I4-1) /.2123405382,.5905331356,.9114120405/ + DATA (RWKSI(I),I=I3,I4-1) /.0698269799,.2292411064,.2009319137/ +C N=4 + DATA (RZKSI(I),I=I4,I5-1) + > /.1397598643,.4164095676,.7231569864,.9428958039/ + DATA (RWKSI(I),I=I4,I5-1) + > /.0311809710,.1298475476,.2034645680,.1355069134/ +C N=5 + DATA (RZKSI(I),I=I5,I6-1) /.0985350858,.3045357266, + > .5620251898,.8019865821,.9601901429/ + DATA (RWKSI(I),I=I5,I6-1) /.0157479145,.0739088701, + > .1463869871,.1671746381,.0967815902/ +C N=6 + DATA (RZKSI(I),I=I6,I7-1) /.0730543287,.2307661380,.4413284812, + > .6630153097,.8519214003,.9706835728/ + DATA (RWKSI(I),I=I6,I7-1) /.0087383018,.0439551656,.0986611509, + > .1407925538,.1355424972,.0723103307/ +C N=7 + DATA (RZKSI(I),I=I7,I8-1) /.0562625605,.1802406917,.3526247171, + > .5471536263,.7342101772,.8853209468,.9775206136/ + DATA (RWKSI(I),I=I7,I8-1) /.0052143622,.0274083567,.0663846965, + > .1071250657,.1273908973,.1105092582,.0559673634/ +C N=8 + DATA (RZKSI(I),I=I8,IFN) /.0446339553,.1443662570,.2868247571, + > .4548133152,.6280678354,.7856915206,.9086763921,.9822200949/ + DATA (RWKSI(I),I=I8,IFN) /.0032951914,.0178429027,.0454393195, + > .0791995995,.1060473594,.1125057995,.0911190236,.0445508044/ +* + IDEP=0 + IFIN=0 + IF( NGPT.EQ. 1 ) THEN + IDEP=I1 + IFIN=I2-1 + ELSE IF( NGPT.EQ. 2 ) THEN + IDEP=I2 + IFIN=I3-1 + ELSE IF( NGPT.EQ. 3 ) THEN + IDEP=I3 + IFIN=I4-1 + ELSE IF( NGPT.EQ. 4 ) THEN + IDEP=I4 + IFIN=I5-1 + ELSE IF( NGPT.EQ. 5 ) THEN + IDEP=I5 + IFIN=I6-1 + ELSE IF( NGPT.EQ. 6 ) THEN + IDEP=I6 + IFIN=I7-1 + ELSE IF( NGPT.EQ. 7 ) THEN + IDEP=I7 + IFIN=I8-1 + ELSE IF( NGPT.EQ. 8 ) THEN + IDEP=I8 + IFIN=IFN + ELSE + XINF=0.0 + XSUP=1.0 + CALL ALGPT(NGPT,XINF,XSUP,ZJKSI,WJKSI) + ENDIF + IF(NGPT.LE.8) THEN +C------ +C INITIALIZE ZJKSI AND WJKSI FROM DATA BASE +C------ + IUP=1 + DO 100 I=IDEP,IFIN + ZJKSI(IUP)=RZKSI(I) + WJKSI(IUP)=RWKSI(I) + IUP=IUP+1 + 100 CONTINUE + ELSE +C------ +C USE GAUSS-LEGENDRE INTEGRATION POINTS INSTEAD OF GAUSS-JACOBI +C------ + DO 110 I=1,NGPT + WJKSI(I)=WJKSI(I)*ZJKSI(I) + 110 CONTINUE + ENDIF + RETURN + END diff --git a/Utilib/src/ALGPT.f b/Utilib/src/ALGPT.f new file mode 100644 index 0000000..ae46666 --- /dev/null +++ b/Utilib/src/ALGPT.f @@ -0,0 +1,408 @@ +*DECK ALGPT + SUBROUTINE ALGPT(NGPT,XINF,XSUP,ZGKSI,WGKSI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* returns gauss integration points and weights for integration limits +* specified and to the order specified +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and O. Vagner +* +*Reference: +* integral of F(X)DX , from XINF to XSUP is given by summ from i=1 to +* NGPT of F(ZGKSI(I))*WGKSI(I) +* the points ZGKSI and weights WGKSI are generated according +* to the technique described in Handbook of mathematical functions +* M. Abramowitz and I. Stegun, Dover Publication Inc. (1972); +* all points and weights are taken from A.H. Stroud and D. Secrest, +* gaussian quadrature formulas, Prentice-Hall (1966). +* +*Parameters: input +* NGPT number of gauss points +* XINF lower integration limit +* XSUP upper integration limit +* +*Parameters: output +* ZGKSI integration points +* WGKSI integration weights +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGPT + REAL XINF,XSUP,ZGKSI(NGPT),WGKSI(NGPT) +*---- +* LOCAL VARIABLES +*---- + PARAMETER ( I2= 1, I3= 2, I4= 3, I5= 5, I6= 7, I7=10, I8=13, + > I9=17,I10=21,I11=26,I12=31,I13=37,I14=43,I15=50, + > I16=57,I17=65,I18=73,I19=82,I20=91,I24=101,I28=113, + > I32=127,I64=143,IFN=174) + PARAMETER ( HALF=0.5E0, TWO=2.0E0 ) + REAL RZKSI(IFN),RWKSI(IFN),FW,FC + CHARACTER CERROR*4 + SAVE RZKSI,RWKSI +C N=2 + DATA (RZKSI(I),I=I2,I3-1) / .577350269189626E0/ + DATA (RWKSI(I),I=I2,I3-1) / 1.000000000000000E0/ +C N=3 + DATA (RZKSI(I),I=I3,I4-1) / .774596669241483E0/ + DATA (RWKSI(I),I=I3,I4-1) / .555555555555556E0/ +C N=4 + DATA (RZKSI(I),I=I4,I5-1) / .339981043584856E0, + > .861136311594053E0/ + DATA (RWKSI(I),I=I4,I5-1) / .652145154862546E0, + > .347854845137454E0/ +C N=5 + DATA (RZKSI(I),I=I5,I6-1) / .538469310105683E0, + > .906179845938664E0/ + DATA (RWKSI(I),I=I5,I6-1) / .478628670499366E0, + > .236926885056189E0/ +C N=6 + DATA (RZKSI(I),I=I6,I7-1) / .238619186083197E0, + > .661209386466265E0, + > .932469514203152E0/ + DATA (RWKSI(I),I=I6,I7-1) / .467913934572691E0, + > .360761573048139E0, + > .171324492379170E0/ +C N=7 + DATA (RZKSI(I),I=I7,I8-1) / .405845151377397E0, + > .741531185599394E0, + > .949107912342759E0/ + DATA (RWKSI(I),I=I7,I8-1) / .381830050505119E0, + > .279705391489277E0, + > .129484966168870E0/ +C N=8 + DATA (RZKSI(I),I=I8,I9-1) / .183434642495650E0, + > .525532409916329E0, + > .796666477413627E0, + > .960289856497536E0/ + DATA (RWKSI(I),I=I8,I9-1) / .362683783378362E0, + > .313706645877887E0, + > .222381034453374E0, + > .101228536290376E0/ +C N=9 + DATA (RZKSI(I),I=I9,I10-1) / .324253423403809E0, + > .613371432700590E0, + > .836031107326636E0, + > .968160239507626E0/ + DATA (RWKSI(I),I=I9,I10-1) / .312347077040003E0, + > .260610696402935E0, + > .180648160694857E0, + > .081274388361574E0/ +C N=10 + DATA (RZKSI(I),I=I10,I11-1) / .148874338981631E0, + > .433395394129247E0, + > .679409568299024E0, + > .865063366688985E0, + > .973906528517172E0/ + DATA (RWKSI(I),I=I10,I11-1) / .295524224714753E0, + > .269266719309996E0, + > .219086362515982E0, + > .149451349150581E0, + > .066671344308688E0/ +C N=11 + DATA (RZKSI(I),I=I11,I12-1) / + > .978228658146057E0,.887062599768095E0, + > .730152005574049E0,.519096129206812E0, + > .269543155952345E0/ + DATA (RWKSI(I),I=I11,I12-1) / + > .055668567116174E0,.125580369464905E0, + > .186290210927734E0,.233193764591990E0, + > .262804544510247E0/ +C N=12 + DATA (RZKSI(I),I=I12,I13-1) / + > .125233408511469E0,.367831498998180E0, + > .587317954286617E0,.769902674194305E0, + > .904117256370475E0,.981560634246719E0/ + DATA (RWKSI(I),I=I12,I13-1) / + > .249147045813403E0,.233492536538355E0, + > .203167426723066E0,.160078328543346E0, + > .106939325995318E0,.047175336386512E0/ +C N=13 + DATA (RZKSI(I),I=I13,I14-1) / + > .984183054718588E0,.917598399222978E0, + > .801578090733310E0,.642349339440340E0, + > .448492751036447E0,.230458315955135E0/ + DATA (RWKSI(I),I=I13,I14-1) / + > .040484004765316E0,.092121499837728E0, + > .138873510219787E0,.178145980761946E0, + > .207816047536888E0,.226283180262897E0/ +C N=14 + DATA (RZKSI(I),I=I14,I15-1) / + > .986283808696812E0,.928434883663573E0, + > .827201315069765E0,.687292904811685E0, + > .515248636358154E0,.319112368927890E0, + > .108054948707344E0/ + DATA (RWKSI(I),I=I14,I15-1) / + > .035119460331752E0,.080158087159760E0, + > .121518570687903E0,.157203167158193E0, + > .185538397477938E0,.205198463721296E0, + > .215263853463158E0/ +C N=15 + DATA (RZKSI(I),I=I15,I16-1) / + > .987992518020485E0,.937273392400706E0, + > .848206583410427E0,.724417731360170E0, + > .570972172608539E0,.394151347077563E0, + > .201194093997434E0/ + DATA (RWKSI(I),I=I15,I16-1) / + > .030753241996117E0,.070366047488108E0, + > .107159220467172E0,.139570677926154E0, + > .166269205816994E0,.186161000015562E0, + > .198431485327111E0/ +C N=16 + DATA (RZKSI(I),I=I16,I17-1) / + > .095012509837637E0,.281603550779259E0, + > .458016777657227E0,.617876244402644E0, + > .755404408355003E0,.865631202387832E0, + > .944575023073233E0,.989400934991650E0/ + DATA (RWKSI(I),I=I16,I17-1) / + > .189450610455068E0,.182603415044924E0, + > .169156519395003E0,.149595988816577E0, + > .124628971255534E0,.095158511682493E0, + > .062253523938648E0,.027152459411754E0/ +C N=17 + DATA (RZKSI(I),I=I17,I18-1) / + > .990575475314417E0,.950675521768768E0, + > .880239153726986E0,.781514003896801E0, + > .657671159216691E0,.512690537086477E0, + > .351231763453876E0,.178484181495848E0/ + DATA (RWKSI(I),I=I17,I18-1) / + > .024148302868548E0,.055459529373987E0, + > .085036148317179E0,.111883847193404E0, + > .135136368468525E0,.154045761076810E0, + > .168004102156450E0,.176562705366993E0/ +C N=18 + DATA (RZKSI(I),I=I18,I19-1) / + > .991565168420930E0,.955823949571397E0, + > .892602466497556E0,.803704958972523E0, + > .691687043060353E0,.559770831073947E0, + > .411751161462843E0,.251886225691505E0, + > .084775013041735E0/ + DATA (RWKSI(I),I=I18,I19-1) / + > .021616013526483E0,.049714548894970E0, + > .076425730254889E0,.100942044106287E0, + > .122555206711478E0,.140642914670651E0, + > .154684675126265E0,.164276483745833E0, + > .169142382963143E0/ +C N=19 + DATA (RZKSI(I),I=I19,I20-1) / + > .992406843843584E0,.960208152134830E0, + > .903155903614818E0,.822714656537143E0, + > .720966177335229E0,.600545304661681E0, + > .464570741375961E0,.316564099963630E0, + > .160358645640225E0/ + DATA (RWKSI(I),I=I19,I20-1) / + > .019461788229726E0,.044814226765700E0, + > .069044542737641E0,.091490021622450E0, + > .111566645547334E0,.128753962539336E0, + > .142606702173607E0,.152766042065860E0, + > .158968843393954E0/ +C N=20 + DATA (RZKSI(I),I=I20,I24-1) / + > .076526521133497E0,.227785851141645E0, + > .373706088715420E0,.510867001950827E0, + > .636053680726515E0,.746331906460151E0, + > .839116971822219E0,.912234428251326E0, + > .963971927277914E0,.993128599185095E0/ + DATA (RWKSI(I),I=I20,I24-1) / + > .152753387130726E0,.149172986472604E0, + > .142096109318382E0,.131688638449177E0, + > .118194531961518E0,.101930119817240E0, + > .083276741576705E0,.062672048334109E0, + > .040601429800387E0,.017614007139152E0/ +C N=24 + DATA (RZKSI(I),I=I24,I28-1) / + > .995187219997021E0,.974728555971309E0, + > .938274552002733E0,.886415527004401E0, + > .820001985973903E0,.740124191578554E0, + > .648093651936975E0,.545421471388839E0, + > .433793507626045E0,.315042679696163E0, + > .191118867473616E0,.064056892862605E0/ + DATA (RWKSI(I),I=I24,I28-1) / + > .012341229799987E0,.028531388628934E0, + > .044277438817420E0,.059298584915437E0, + > .073346481411080E0,.086190161531953E0, + > .097618652104114E0,.107444270115966E0, + > .115505668053726E0,.121670472927803E0, + > .125837456346828E0,.127938195346752E0/ +C N=28 + DATA (RZKSI(I),I=I28,I32-1) / + > .996442497573954E0,.981303165370873E0, + > .954259280628938E0,.915633026392132E0, + > .865892522574395E0,.805641370917179E0, + > .735610878013632E0,.656651094038865E0, + > .569720471811402E0,.475874224955118E0, + > .376251516089079E0,.272061627635178E0, + > .164569282133380E0,.055079289884034E0/ + DATA (RWKSI(I),I=I28,I32-1) / + > .009124282593094E0,.021132112592771E0, + > .032901427782304E0,.044272934759004E0, + > .055107345675717E0,.065272923966999E0, + > .074646214234569E0,.083113417228901E0, + > .090571744393033E0,.096930657997930E0, + > .102112967578061E0,.106055765922846E0, + > .108711192258294E0,.110047013016475E0/ +C N=32 + DATA (RZKSI(I),I=I32,I64-1) / + > .048307665687738E0,.144471961582796E0, + > .239287362252137E0,.331868602282128E0, + > .421351276130635E0,.506899908932229E0, + > .587715757240762E0,.663044266930215E0, + > .732182118740290E0,.794483795967942E0, + > .849367613732570E0,.896321155766052E0, + > .934906075937740E0,.964762255587506E0, + > .985611511545268E0,.997263861849482E0/ + DATA (RWKSI(I),I=I32,I64-1) / + > .096540088514728E0,.095638720079275E0, + > .093844399080805E0,.091173878695764E0, + > .087652093004404E0,.083311924226947E0, + > .078193895787070E0,.072345794108849E0, + > .065822222776362E0,.058684093478536E0, + > .050998059262376E0,.042835898022227E0, + > .034273862913021E0,.025392065309262E0, + > .016274394730906E0,.007018610009470E0/ +C N=64 + DATA (RZKSI(I),I=I64,IFN) / + > .024350292663424E0,.072993121787799E0,.121462819296121E0, + > .169644420423993E0,.217423643740007E0,.264687162208767E0, + > .311322871990211E0,.357220158337668E0,.402270157963992E0, + > .446366017253464E0,.489403145707053E0,.531279464019894E0, + > .571895646202634E0,.611155355172393E0,.648965471254657E0, + > .685236313054233E0,.719881850171611E0,.752819907260532E0, + > .783972358943341E0,.813265315122798E0,.840629296252580E0, + > .865999398154093E0,.889315445995114E0,.910522137078503E0, + > .929569172131940E0,.946411374858403E0,.961008799652054E0, + > .973326827789911E0,.983336253884626E0,.991013371476744E0, + > .996340116771955E0,.999305041735772E0/ + DATA (RWKSI(I),I=I64,IFN) / + > .048690957009140E0,.048575467441503E0,.048344762234803E0, + > .047999388596458E0,.047540165714830E0,.046968182816210E0, + > .046284796581314E0,.045491627927418E0,.044590558163757E0, + > .043583724529323E0,.042473515123654E0,.041262563242624E0, + > .039953741132720E0,.038550153178616E0,.037055128540240E0, + > .035472213256882E0,.033805161837142E0,.032057928354852E0, + > .030234657072402E0,.028339672614259E0,.026377469715055E0, + > .024352702568711E0,.022270173808383E0,.020134823153530E0, + > .017951715775697E0,.015726030476025E0,.013463047896719E0, + > .011168139460131E0,.008846759826364E0,.006504457968978E0, + > .004147033260562E0,.001783280721696E0/ +* + IDEP=0 + IFIN=0 + FW=HALF*(XSUP-XINF) + FC=HALF*(XSUP+XINF) + IF( NGPT.EQ. 1 ) THEN + ZGKSI(1)=FC + WGKSI(1)=TWO*FW + RETURN + ELSE IF( NGPT.EQ. 2 ) THEN + IDEP=I2 + IFIN=I3-1 + ELSE IF( NGPT.EQ. 3 ) THEN + IDEP=I3 + IFIN=I4-1 + ELSE IF( NGPT.EQ. 4 ) THEN + IDEP=I4 + IFIN=I5-1 + ELSE IF( NGPT.EQ. 5 ) THEN + IDEP=I5 + IFIN=I6-1 + ELSE IF( NGPT.EQ. 6 ) THEN + IDEP=I6 + IFIN=I7-1 + ELSE IF( NGPT.EQ. 7 ) THEN + IDEP=I7 + IFIN=I8-1 + ELSE IF( NGPT.EQ. 8 ) THEN + IDEP=I8 + IFIN=I9-1 + ELSE IF( NGPT.EQ. 9 ) THEN + IDEP=I9 + IFIN=I10-1 + ELSE IF( NGPT.EQ.10 ) THEN + IDEP=I10 + IFIN=I11-1 + ELSE IF( NGPT.EQ.11 ) THEN + IDEP=I11 + IFIN=I12-1 + ELSE IF( NGPT.EQ.12 ) THEN + IDEP=I12 + IFIN=I13-1 + ELSE IF( NGPT.EQ.13 ) THEN + IDEP=I13 + IFIN=I14-1 + ELSE IF(NGPT.EQ.14 ) THEN + IDEP=I14 + IFIN=I15-1 + ELSE IF(NGPT.EQ.15 ) THEN + IDEP=I15 + IFIN=I16-1 + ELSE IF(NGPT.EQ.16 ) THEN + IDEP=I16 + IFIN=I17-1 + ELSE IF(NGPT.EQ.17 ) THEN + IDEP=I17 + IFIN=I18-1 + ELSE IF(NGPT.EQ.18 ) THEN + IDEP=I18 + IFIN=I19-1 + ELSE IF(NGPT.EQ.19 ) THEN + IDEP=I19 + IFIN=I20-1 + ELSE IF( NGPT.EQ.20 ) THEN + IDEP=I20 + IFIN=I24-1 + ELSE IF( NGPT.EQ.24 ) THEN + IDEP=I24 + IFIN=I28-1 + ELSE IF( NGPT.EQ.28 ) THEN + IDEP=I28 + IFIN=I32-1 + ELSE IF( NGPT.EQ.32 ) THEN + IDEP=I32 + IFIN=I64-1 + ELSE IF( NGPT.EQ.64 ) THEN + IDEP=I64 + IFIN=IFN + ELSE + WRITE(CERROR,'(I4)') NGPT + CALL XABORT('ALGPT:INVALID NBR.OF GAUSS PTS.='//CERROR//' *** + > 1 TO 20,24,28,32,64 PTS. ARE PERMITTED') + ENDIF +C------ +C INITIALIZE ZGKSI AND WGKSI STARTING FROM BOTTOM WITH NEGATIVE +C AND FINISHING WITH POSITIVE +C------ + IUP=1 + IDN=NGPT + DO 100 I=IFIN,IDEP,-1 + ZGKSI(IUP)=-FW*RZKSI(I)+FC + WGKSI(IUP)=FW*RWKSI(I) + ZGKSI(IDN)=FW*RZKSI(I)+FC + WGKSI(IDN)=FW*RWKSI(I) + IUP=IUP+1 + IDN=IDN-1 + 100 CONTINUE +C------ +C FOR ODD NGPT, CENTRAL POINT IS 0.0 AND WEIGHT IS (2.0-TOTAL WEIGHT) +C------ + IF(IUP.EQ.IDN) THEN + ZGKSI(IUP)=FC + DO 110 I=1,IUP-1 + FW=FW-WGKSI(I) + 110 CONTINUE + WGKSI(IUP)=TWO*FW + ENDIF + RETURN + END diff --git a/Utilib/src/ALGUER.f b/Utilib/src/ALGUER.f new file mode 100644 index 0000000..ddd93a1 --- /dev/null +++ b/Utilib/src/ALGUER.f @@ -0,0 +1,92 @@ +*DECK ALGUER + SUBROUTINE ALGUER(A,M,X,ITS,LFAIL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* find one root of a polynomial. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* A polynomial coefficients. DIMENSION A(M+1) +* M polynomial order. +* +*Parameters: output +* X complex single root. +* ITS number of iterations. +* LFAIL set to .true. in case of failure. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER M,ITS + COMPLEX*16 A(M+1),X + LOGICAL LFAIL +*---- +* LOCAL VARIABLES +*---- + INTEGER MAXIT,MR,MT + DOUBLE PRECISION EPSS + PARAMETER (EPSS=2.D-7,MR=8,MT=10,MAXIT=MT*MR) + INTEGER ITER,J + DOUBLE PRECISION ABX,ABP,ABM,ERR,FRAC(MR) + COMPLEX*16 DX,X1,B,D,F,G,H,SQ,GP,GM,G2,TMP + SAVE FRAC + DATA FRAC /.5D0,.25D0,.75D0,.13D0,.38D0,.62D0,.88D0,1.D0/ +* + LFAIL=.FALSE. + DO 12 ITER=1,MAXIT + ITS=ITER + B=A(M+1) + ERR=ABS(B) + D=CMPLX(0.D0,0.D0,KIND=KIND(D)) + F=CMPLX(0.D0,0.D0,KIND=KIND(F)) + ABX=ABS(X) + DO 11 J=M,1,-1 + F=X*F+D + D=X*D+B + B=X*B+A(J) + ERR=ABS(B)+ABX*ERR +11 CONTINUE + ERR=EPSS*ERR + IF(ABS(B).LE.ERR) THEN + RETURN + ELSE + G=D/B + G2=G*G + H=G2-2.D0*F/B + SQ=SQRT((M-1)*(M*H-G2)) + GP=G+SQ + GM=G-SQ + ABP=ABS(GP) + ABM=ABS(GM) + IF(ABP.LT.ABM) GP=GM + IF (MAX(ABP,ABM).GT.0.D0) THEN + DX=M/GP + ELSE + TMP=CMPLX(LOG(1.D0+ABX),DBLE(ITER),KIND=KIND(TMP)) + DX=EXP(TMP) + ENDIF + ENDIF + X1=X-DX + IF(X.EQ.X1)RETURN + IF (MOD(ITER,MT).NE.0) THEN + X=X1 + ELSE + X=X-DX*FRAC(ITER/MT) + ENDIF +12 CONTINUE + LFAIL=.TRUE. + RETURN + END diff --git a/Utilib/src/ALH12.f b/Utilib/src/ALH12.f new file mode 100644 index 0000000..282a583 --- /dev/null +++ b/Utilib/src/ALH12.f @@ -0,0 +1,108 @@ +*DECK ALH12 + SUBROUTINE ALH12(MODE,LPIVOT,L1,M,U,UP,C,ICE,ICV,NCV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* construction and/or application of a single Householder +* transformation (Q = I + U*(U**T)/B). +* +*Author(s): C. L. Lawson and R. J. Hanson +* +*Parameters: input +* MODE algorithm flag (=1/2: Selects algorithm H1 to construct and +* apply a Householder transformation / Algorithm H2 to apply a +* previously constructed transformation). +* LPIVOT index of the pivot element. +* L1,M if L1.le.M, the transformation will be constructed to +* zero elements indexed from L1 through M. If L1.gt.M, +* the subroutine does an identity transformation. +* U pivot vector (if MODE=1). At exit, contains quantities +* defining the vector U of the Householder transformation. +* On entry with MODE=2, U should contain information +* previously computed with MODE=1. +* C matrix which will be regarded as a set of vectors to which the +* Householder transformation is to be applied. +* ICE storage increment between elements of vectors in C. +* ICV storage increment between vectors in C. +* NCV number of vectors in C to be transformed. if NCV.le.0, no +* operations will be done on C. +* +*Parameters: output +* U quantitie defining the vector U of the Householder +* transformation. These will not be modified during the entry +* with MODE=2. +* UP quantity defining the vector U of the Householder +* transformation. On entry with MODE = 2, UP should +* contain information previously computed with MODE=1. These +* will not be modified during the entry with MODE=2. +* C set of transformed vectors. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER MODE, LPIVOT, L1, M, ICE, ICV, NCV + DOUBLE PRECISION U(M),C(M),UP +*---- +* Local variables +*---- + INTEGER I, I2, I3, I4, INCR, J + DOUBLE PRECISION B, CL, CLINV, SM +* + IF(0.GE.LPIVOT .OR. LPIVOT.GE.L1 .OR. L1.GT.M) RETURN + CL = ABS(U(LPIVOT)) + IF(MODE.NE.2) THEN +*---- +* Construct the transformation. +*---- + DO J = L1, M + CL=MAX(ABS(U(J)),CL) + ENDDO + IF(CL.LE.0) RETURN + CLINV = 1.0D0 / CL + SM = (U(LPIVOT)*CLINV) ** 2 + SUM( (U(L1:M)*CLINV)**2 ) + CL = CL * SQRT(SM) + IF(U(LPIVOT).GT.0) THEN + CL = -CL + ENDIF + UP = U(LPIVOT) - CL + U(LPIVOT) = CL + ELSE +*---- +* Apply the transformation I+U*(U**T)/B to C. +*---- + IF(CL.LE.0) RETURN + ENDIF + IF(NCV.LE.0) RETURN + B = UP * U(LPIVOT) +*---- +* B must be nonpositive here. If B = 0., return. +*---- + IF(B.LT.0.0) THEN + B = 1.0D0 / B + I2 = 1 - ICV + ICE * (LPIVOT-1) + INCR = ICE * (L1-LPIVOT) + DO J = 1, NCV + I2 = I2 + ICV + I3 = I2 + INCR + I4 = I3 + SM = C(I2) * UP + DO I = L1, M + SM = SM + C(I3) * U(I) + I3 = I3 + ICE + ENDDO + IF(SM.NE.0) THEN + SM = SM * B + C(I2) = C(I2) + SM * UP + DO I = L1, M + C(I4) = C(I4) + SM * U(I) + I4 = I4 + ICE + ENDDO + ENDIF + ENDDO + ENDIF + RETURN + END diff --git a/Utilib/src/ALHQR.f90 b/Utilib/src/ALHQR.f90 new file mode 100644 index 0000000..35ac064 --- /dev/null +++ b/Utilib/src/ALHQR.f90 @@ -0,0 +1,283 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! find the eigenvalues and corresponding eigenvectors of equation +! (a-eval)*evect=0 using the power method with the shifted Hessenberg +! QR algorithm. +! +!Copyright: +! Copyright (C) 2020 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!Reference: +! G. E. Robles, "Implementing the QR algorithm for efficiently +! computing matrix eigenvalues and eigenvectors," Final Degree +! Dissertation in Mathematics, Universidad del Pais Vasco, Spain +! (2017). +! +!Parameters: input +! ndim dimensioned column length of A. +! n order of matrix A. +! A input matrix. +! maxiter maximum number of iterations. +! +!Parameters: output +! iter actual number of iterations. +! V eigenvector matrix. +! D eigenvalue diagonal matrix. +! +!----------------------------------------------------------------------- +! +subroutine ALHQR(ndim,n,A,maxiter,iter,V,D) + implicit none + !---- + ! Subroutine arguments + !---- + integer, intent(in) :: ndim,n,maxiter + integer, intent(out) :: iter + real(kind=8), dimension(ndim,n), intent(in) :: A + complex(kind=8), dimension(n,n), intent(out) :: V,D + !---- + ! Local variables + !---- + integer :: i,j,k,i1,i2,nset,ier,ii + complex(kind=8) :: kappa,p,qq,r,mu,csum,denom,m(2,2) + real(kind=8) :: sgn,tau,nu,normH,sum,AA(2,2),BB(2,2),CC(2,2) + real(kind=8), parameter :: eps=epsilon(A) + !---- + ! Allocatable arrays + !---- + integer, allocatable, dimension(:) :: iset + real(kind=8), allocatable, dimension(:) :: c + complex(kind=8), allocatable, dimension(:) :: s,t,work1d + real(kind=8), allocatable, dimension(:,:) :: VR + complex(kind=8), allocatable, dimension(:,:) :: H,Q,work2d + !---- + ! Perform Householder transformation to upper Hessenberg form + !---- + allocate(H(n,n), Q(n,n), VR(n,n-2)) + H(:n,:n)=A(:n,:n) + do k = 1,(n-2) + VR(k+1:n,k) = real(H(k+1:n,k)) + sgn = sign(1.0d0,VR(k+1,k)) + VR(k+1,k) = VR(k+1,k) + sgn * sqdotv(VR(k+1:n,k)) + sum = sqdotv(VR(k+1:n,k)) + if(sum /= 0.d0) VR(k+1:n,k) = VR(k+1:n,k) / sum + H(k+1:n,k:n) = H(k+1:n,k:n) - 2.0d0 * matmul(reshape(VR(k+1:n,k),(/n-k, 1/)), & + reshape(matmul(VR(k+1:n,k),H(k+1:n,k:n)),(/1, n-k+1/))) + H(:,k+1:n) = H(:,k+1:n) - 2.0d0 * matmul(reshape(matmul(H(:,k+1:n),VR(k+1:n,k)),(/n, 1/)), & + reshape(VR(k+1:n,k),(/1, n-k/))) + enddo + !---- + ! Construct Q matrix + !---- + Q(:n,:n) = 0.0D0 + do j=1,n + Q(j,j)=1.0d0 + enddo + do j = (n-2),1,-1 + Q(j+1:n,:n) = Q(j+1:n,:n) - 2.0d0 * matmul(reshape(VR(j+1:n,j),(/n-j, 1/)), & + reshape(matmul(VR(j+1:n,j),Q((j+1):n,:)),(/1, n/))) + enddo + deallocate(VR) + !---- + ! Perform Schur factorization + !---- + i2 = n + allocate(c(n),s(n),t(n)) + c(:n)=0.0d0; s(:n)=0.0d0; t(:n)=0.0d0; + iter = 0 + do + iter = iter + 1 + if(iter > maxiter) then + call xabort('ALHQR: maximum number of iterations exceeded.') + endif + ! Check subdiagonal for near zeros, deflating points. Finds deflating rows + ! on a complex Schur form matrix. + i1 = i2 + normH = sqdotm(abs(H(:n,:n))) + do + if(i1 == 1) exit + if(abs(H(i1,i1-1)) < eps*normH) then + H(i1,i1-1) = 0.0d0 + if(i1 == i2) then + i2 = i1 - 1; i1 = i1 - 1; + else + exit + endif + else + i1 = i1 - 1 + endif + enddo + !---- + ! End the function if H is upper triangular + !---- + if(i2 == 1) exit + ! Compute Wilkinson shift + kappa = H(i2,i2) + sum = abs(H(i2-1,i2-1)) + abs(H(i2-1,i2)) + abs(H(i2,i2-1)) + abs(H(i2,i2)) + if(sum /= 0) then + qq = (H(i2-1,i2)/sum)*(H(i2,i2-1)/sum) + if(qq /= 0) then + p = 0.5*((H(i2-1,i2-1)/sum) - (H(i2,i2)/sum)) + r = sqrt(p*p + qq); + if( (real(p)*real(r) + imag(p)*imag(r)) < 0 ) then + r = -r + endif + kappa = kappa - sum*(qq/(p+r)) + endif + endif + ! Apply shift to the element of the diagonal that is left out of the loop + H(i1,i1) = H(i1,i1) - kappa + do j = i1,i2-1 ! Loop reducing the matrix to triangular form + ! Apply Givens rotation so that the subdiagonal is set to zero + if(H(j+1,j) == 0) then + c(j) = 1.0d0; s(j) = 0.0d0; + elseif(H(j,j) == 0) then + c(j) = 0.0d0; s(j) = 1; H(j,j) = H(j+1,j); H(j+1,j) = 0.0d0; + else + mu = H(j,j)/abs(H(j,j)) + tau = abs(real(H(j,j))) + abs(imag(H(j,j))) + abs(real(H(j+1,j))) & + + abs(imag(H(j+1,j))) + nu = tau*sqrt(abs(H(j,j)/tau)**2 + abs(H(j+1,j)/tau)**2) + c(j) = abs(H(j,j))/nu + s(j) = mu*conjg(H(j+1,j))/nu + H(j,j) = nu*mu + H(j+1,j) = 0.0d0 + endif + ! Apply shift to diagonal + H(j+1,j+1) = H(j+1,j+1) - kappa + ! Modify the involved rows using a plane rotation + t(j+1:n) = c(j)*H(j,j+1:n) + s(j)*H(j+1,j+1:n) + H(j+1,j+1:n) = c(j)*H(j+1,j+1:n) - conjg(s(j))*H(j,j+1:n) + H(j,j+1:n) = t(j+1:n) + enddo + do k = i1,i2-1 + ! Loop applying the back multiplication using a plane rotation + t(1:k+1) = c(k)*H(1:k+1,k) + conjg(s(k))*H(1:k+1,k+1); + H(1:k+1,k+1) = c(k)*H(1:k+1,k+1) - s(k)*H(1:k+1,k) + H(1:k+1,k) = t(1:k+1) + ! Accumulate transformations using a plane rotation + t(1:n) = c(k)*Q(1:n,k) + conjg(s(k))*Q(1:n,k+1) + Q(1:n,k+1) = c(k)*Q(1:n,k+1) - s(k)*Q(1:n,k) + Q(1:n,k) = t(1:n) + H(k,k) = H(k,k) + kappa + enddo + H(i2,i2) = H(i2,i2) + kappa + enddo + deallocate(t,s,c) + !---- + ! Construct the orthonormal basis + !---- + V(:n,:n)=0.0d0 + D(:n,:n)=0.0d0 + do i=1,n + V(i,i)=1.0d0 + D(i,i)=H(i,i) + enddo + do j=2,n + do i=j-1,1,-1 + denom=H(i,i)-H(j,j) + if(denom /= 0) then + csum=0.0d0 + do k=i+1,j + csum=csum+H(i,k)*V(k,j) + enddo + V(i,j)=V(i,j)-csum/denom + endif + enddo + enddo + V=matmul(Q,V) + deallocate(Q,H) + !---- + ! Sort and normalize the eigensolution + !---- + allocate(iset(n),work1d(n),work2d(n,n)) + do i=1,n + work1d(i) = D(i,i) + enddo + call ALINDX(n, work1d, iset) + do i=1,n + work1d(i) = D(iset(i),iset(i)) + work2d(:n,i) = V(:n,iset(i)) + enddo + do i=1,n + D(i,i)=work1d(i) + enddo + V(:n,:n) = work2d(:n,:n) + deallocate(work2d,work1d) + nset=0 + do i=1,n + if(abs(imag(D(i,i))) > 1.0e-10) then + nset=nset+1 + iset(nset)=i + endif + enddo + do i=1,n + ii=findlc(iset(:nset),i) + if(mod(ii-1,2)+1.eq.1) then + j=iset(ii+1) + m=reshape( (/V(i,i), V(j,i), V(i,j), V(j,j)/), (/2, 2/) ) + m(:,1)=m(:,1)/sqdotv(abs(m(1:2,1))) + m(:,2)=m(:,2)/sqdotv(abs(m(1:2,2))) + AA=reshape( (/real(m(1,1))+real(m(2,1)), aimag(m(1,1))+aimag(m(2,1)), & + -aimag(m(1,1))-aimag(m(2,1)), real(m(1,1))+real(m(2,1)) /), (/2, 2/) ) + BB=reshape( (/real(m(1,2))+real(m(2,2)), -aimag(m(1,2))-aimag(m(2,2)), & + -aimag(m(1,2))-aimag(m(2,2)), -real(m(1,2))-real(m(2,2)) /), (/2, 2/) ) + call ALINVD(2,BB,2,ier) + if(ier.ne.0) call xabort('ALHQR: singular matrix') + CC=matmul(BB,AA) + V(:,i)=V(:,i)*cmplx(CC(1,1),CC(1,2),kind=8) + elseif (mod(ii-1,2)+1.eq.2) then + j=iset(ii-1) + if(abs(D(i,i)-conjg(D(j,j))) > 1.0e-10) then + call xabort('ALHQR: pathological ordering') + endif + D(i,i)=conjg(D(j,j)) + else + D(i,i)=real(D(i,i)) + endif + V(:,i)=V(:,i)/sqdotv(abs(V(:,i))) + enddo + deallocate(iset) + return + + contains + function sqdotv(vec) result(vsum) + ! function emulating the vectorial norm2 function in Fortran 2008 + real(kind=8), dimension(:), intent(in) :: vec + real(kind=8) :: vsum + vsum=sqrt(dot_product(vec(:),vec(:))) + end function sqdotv + function sqdotm(mat) result(vsum) + ! function emulating the matrix norm2 function in Fortran 2008 + real(kind=8), dimension(:,:), intent(in) :: mat + real(kind=8) :: vsum + vsum=0.0d0 + do i=1,size(mat,1) + do j=1,size(mat,2) + vsum=vsum+mat(i,j)**2 + enddo + enddo + vsum=sqrt(vsum) + end function sqdotm + function findlc(iset,itest) result(ii) + ! function emulating the findloc function in Fortran 2008 + integer, dimension(:), intent(in) :: iset + integer, intent(in) :: itest + integer :: ii + ii=0 + do j=1,size(iset) + if(iset(j) == itest) then + ii=j + exit + endif + enddo + end function findlc +end subroutine ALHQR diff --git a/Utilib/src/ALINDX.f b/Utilib/src/ALINDX.f new file mode 100644 index 0000000..9a5005c --- /dev/null +++ b/Utilib/src/ALINDX.f @@ -0,0 +1,123 @@ +*DECK ALINDX + SUBROUTINE ALINDX(n,arr,indx) +* +*----------------------------------------------------------------------- +* +*Purpose: +* indexes an array arr(1:n) such that abs(arr(indx(j))) is in descending +* order for j=1:n. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de MontCOMPLEX(KIND=8) +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* n size of the array a. +* a array a. +* +*Parameters: output +* indx indexing vector. +* +*----------------------------------------------------------------------- +* +*---- +* subroutine arguments +*---- + INTEGER n,indx(n) + COMPLEX(KIND=8) arr(n) +*---- +* local variables +*---- + INTEGER nstack,i,indxt,ir,itemp,j,jstack,k,l + COMPLEX(KIND=8) a + INTEGER, parameter :: M=7 + INTEGER, allocatable, dimension(:) :: istack +* + nstack=2*ceiling(log(real(n))/log(2.0)) + allocate(istack(nstack)) + do j=1,n + indx(j)=j + enddo + jstack=0 + l=1 + ir=n + 1 if(ir-l.lt.M) then + do j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do i=j-1,l,-1 + if(absc(arr(indx(i))).ge.absc(a)) goto 2 + indx(i+1)=indx(i) + enddo + i=l-1 + 2 indx(i+1)=indxt + enddo + if(jstack.eq.0)go to 5 + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(absc(arr(indx(l))).lt.absc(arr(indx(ir))))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(absc(arr(indx(l+1))).lt.absc(arr(indx(ir)))) then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(absc(arr(indx(l))).lt.absc(arr(indx(l+1)))) then + itemp=indx(l) + indx(l)=indx(l+1) + indx(l+1)=itemp + endif + i=l+1 + j=ir + indxt=indx(l+1) + a=arr(indxt) + 3 i=i+1 + if(absc(arr(indx(i))).gt.absc(a)) goto 3 + 4 j=j-1 + if(absc(arr(indx(j))).lt.absc(a)) goto 4 + if(j.ge.i) then + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + goto 3 + endif + indx(l+1)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.nstack) call XABORT('ALINDX: nstack too small.') + if(ir-i+1.ge.j-l) then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + 5 deallocate(istack) + return +* + contains + function absc(val) result(aval) + ! definition of combined value for complex numbers + COMPLEX(kind=8), intent(in) :: val + REAL(kind=8) :: aval + aval=100.0d0*real(val)+aimag(val) + end function absc + END diff --git a/Utilib/src/ALINV.f b/Utilib/src/ALINV.f new file mode 100644 index 0000000..883a848 --- /dev/null +++ b/Utilib/src/ALINV.f @@ -0,0 +1,91 @@ +*DECK ALINV + SUBROUTINE ALINV(N,A,MAX,IER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* in-place inversion of a non singular matrix using gaussian elimination +* with partial pivoting. Simple precision version. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N order of the coefficient matrix. +* A coefficient matrix to be inverted. +* MAX first dimention of matrix A. +* +*Parameters: output +* A inverted matrix. +* IER error flag (execution failure if IER.ne.0). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MAX,IER + REAL A(MAX,N) +*---- +* ALLOCATABLE ARRAY +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IND +* + ALLOCATE(IND(N)) + IN=0 + IER=0 + DO 1 I=1,N + IND(I)=I +1 CONTINUE + DO 12 J=1,N + TEST=0.0 + DO 2 I=J,N + IF (ABS(A(I,J)).LE.TEST) GO TO 2 + TEST=ABS(A(I,J)) + IN=I +2 CONTINUE + IF (TEST.NE.0.0) GO TO 3 + IER=1 + DEALLOCATE(IND) + RETURN +3 PMX=A(IN,J) + A(IN,J)=1.0 + DO 4 I=1,N + PER=A(IN,I)/PMX + A(IN,I)=A(J,I) + A(J,I)=PER +4 CONTINUE + IPER=IND(IN) + IND(IN)=IND(J) + IND(J)=IPER + DO 11 I=1,N + IF (I.EQ.J) GO TO 11 + PMX=A(I,J) + A(I,J)=0.0 + DO 9 K=1,N + A(I,K)=A(I,K)-PMX*A(J,K) +9 CONTINUE +11 CONTINUE +12 CONTINUE + DO 16 J=1,N + DO 13 K=J,N + IF (IND(K).NE.J) GO TO 13 + IN=K + GO TO 14 +13 CONTINUE +14 DO 15 I=1,N + PER=A(I,J) + A(I,J)=A(I,IN) + A(I,IN)=PER + IND(IN)=IND(J) +15 CONTINUE +16 CONTINUE + DEALLOCATE(IND) + RETURN + END diff --git a/Utilib/src/ALINVC.f b/Utilib/src/ALINVC.f new file mode 100644 index 0000000..7b1128f --- /dev/null +++ b/Utilib/src/ALINVC.f @@ -0,0 +1,96 @@ +*DECK ALINVC + SUBROUTINE ALINVC(N,A,MAX,IER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* in-place inversion of a non singular matrix using gaussian elimination +* with partial pivoting. COMPLEX*16 version. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N order of the coefficient matrix. +* A coefficient matrix to be inverted. +* MAX first dimention of matrix A. +* +*Parameters: output +* A inverted matrix. +* IER error flag (execution failure if IER.ne.0). +* +*----------------------------------------------------------------------- +* + IMPLICIT COMPLEX*16 (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MAX,IER + COMPLEX*16 A(MAX,N) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TEST +*---- +* ALLOCATABLE ARRAY +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IND +* + ALLOCATE(IND(N)) + IN=0 + IER=0 + DO 1 I=1,N + IND(I)=I +1 CONTINUE + DO 12 J=1,N + TEST=0.0D0 + DO 2 I=J,N + IF (ABS(A(I,J)).LE.TEST) GO TO 2 + TEST=ABS(A(I,J)) + IN=I +2 CONTINUE + IF (TEST.NE.0.0D0) GO TO 3 + IER=1 + DEALLOCATE(IND) + RETURN +3 PMX=A(IN,J) + A(IN,J)=1.0D0 + DO 4 I=1,N + PER=A(IN,I)/PMX + A(IN,I)=A(J,I) + A(J,I)=PER +4 CONTINUE + IPER=IND(IN) + IND(IN)=IND(J) + IND(J)=IPER + DO 11 I=1,N + IF (I.EQ.J) GO TO 11 + PMX=A(I,J) + A(I,J)=0.0D0 + DO 9 K=1,N + A(I,K)=A(I,K)-PMX*A(J,K) +9 CONTINUE +11 CONTINUE +12 CONTINUE + DO 16 J=1,N + DO 13 K=J,N + IF (IND(K).NE.J) GO TO 13 + IN=K + GO TO 14 +13 CONTINUE +14 DO 15 I=1,N + PER=A(I,J) + A(I,J)=A(I,IN) + A(I,IN)=PER + IND(IN)=IND(J) +15 CONTINUE +16 CONTINUE + DEALLOCATE(IND) + RETURN + END diff --git a/Utilib/src/ALINVD.f b/Utilib/src/ALINVD.f new file mode 100644 index 0000000..f059773 --- /dev/null +++ b/Utilib/src/ALINVD.f @@ -0,0 +1,92 @@ +*DECK ALINVD + SUBROUTINE ALINVD(N,A,MAX,IER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* in-place inversion of a non singular matrix using gaussian elimination +* with partial pivoting. Double precision version. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N order of the coefficient matrix. +* A coefficient matrix to be inverted. +* MAX first dimention of matrix A. +* +*Parameters: output +* A inverted matrix. +* IER error flag (execution failure if IER.ne.0). +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MAX,IER + DOUBLE PRECISION A(MAX,N) +*---- +* ALLOCATABLE ARRAY +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IND +* + ALLOCATE(IND(N)) + IN=0 + IER=0 + DO 1 I=1,N + IND(I)=I +1 CONTINUE + DO 12 J=1,N + TEST=0.0D0 + DO 2 I=J,N + IF (ABS(A(I,J)).LE.TEST) GO TO 2 + TEST=ABS(A(I,J)) + IN=I +2 CONTINUE + IF (TEST.NE.0.0D0) GO TO 3 + IER=1 + DEALLOCATE(IND) + RETURN +3 PMX=A(IN,J) + A(IN,J)=1.0D0 + DO 4 I=1,N + PER=A(IN,I)/PMX + A(IN,I)=A(J,I) + A(J,I)=PER +4 CONTINUE + IPER=IND(IN) + IND(IN)=IND(J) + IND(J)=IPER + DO 11 I=1,N + IF (I.EQ.J) GO TO 11 + PMX=A(I,J) + A(I,J)=0.0D0 + DO 9 K=1,N + A(I,K)=A(I,K)-PMX*A(J,K) +9 CONTINUE +11 CONTINUE +12 CONTINUE + DO 16 J=1,N + DO 13 K=J,N + IF (IND(K).NE.J) GO TO 13 + IN=K + GO TO 14 +13 CONTINUE +14 DO 15 I=1,N + PER=A(I,J) + A(I,J)=A(I,IN) + A(I,IN)=PER + IND(IN)=IND(J) +15 CONTINUE +16 CONTINUE + DEALLOCATE(IND) + RETURN + END diff --git a/Utilib/src/ALLDLF.f b/Utilib/src/ALLDLF.f new file mode 100644 index 0000000..b4f767b --- /dev/null +++ b/Utilib/src/ALLDLF.f @@ -0,0 +1,72 @@ +*DECK ALLDLF + SUBROUTINE ALLDLF (L4,ASS,MU1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* in-place L-D-L(T) factorization of a symmetric positive definite +* matrix in compressed diagonal storage mode. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* ASS coefficient matrix in compressed diagonal storage mode. +* A(I,J)=ASS(MU1(I)-I+J) if J.le.I and J.gt.I+MU1(I-1)-MU1(I) +* =A(J,I) if I.lt.J +* =0.0 else +* DIMENSION ASS(MU1(L4)-MU1(1)+1) +* MU1 position of each diagonal element in vector ASS. +* +*Parameters: output +* ASS LDL(T) factors. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4) + REAL ASS(*) +* + ASS(MU1(1))=1./ASS(MU1(1)) + IF (L4.EQ.1) RETURN + DO K=2,L4 + KLL=K-1 + K1=MU1(K)-K + KM=MU1(K-1)+1-K1 + KMM=KM+1 + IF(KMM-K .LE. 0) THEN + IF(KMM-K .LT. 0) THEN + DO I=KMM,KLL + R=ASS(K1+I) + ASS(K1+I)=0.0 + S=0.0 + I1=MU1(I)-I + IM=MU1(I-1)+1-I1 + IMIN=MAX0(IM,KM) + DO J=IMIN,I + S=S+ASS(K1+J)*ASS(I1+J) + ENDDO + ASS(K1+I)=R-S + ENDDO + ENDIF + S=0.0 + DO I=KM,KLL + R=ASS(K1+I) + ASS(K1+I)=R*ASS(MU1(I)) + S=S+R*ASS(K1+I) + ENDDO + ASS(MU1(K))=ASS(MU1(K))-S + ENDIF + ASS(MU1(K))=1./ASS(MU1(K)) + ENDDO + RETURN + END diff --git a/Utilib/src/ALLDLM.f b/Utilib/src/ALLDLM.f new file mode 100644 index 0000000..4186798 --- /dev/null +++ b/Utilib/src/ALLDLM.f @@ -0,0 +1,70 @@ +*DECK ALLDLM + SUBROUTINE ALLDLM (L4,ASS,VEC,Z,MU1,ITY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* multiplication of a symmetric matrix in compressed diagonal storage +* mode by a vector. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* ASS coefficient matrix in compressed diagonal storage mode. +* DIMENSION ASS(MU1(L4)) +* VEC vector to multiply. +* Z vector that will be added to the result if ITY=2. +* MU1 position of each diagonal element in vector ASS. +* ITY type of multiplication (ITY=1: Z=ASS*VEC; +* ITY=2: Z=Z+(ASS-DIAG(ASS))*VEC). +* +*Parameters: output +* Z solution of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4),ITY + REAL ASS(*),VEC(L4),Z(L4) +* + GO TO (10,60),ITY +* +* CALCULATION OF Z=ASS*VEC. + 10 Z(1)=ASS(MU1(1))*VEC(1) + I1=MU1(1)+1 + DO 50 K=2,L4 + I2=MU1(K) + KEY1=I2-K + ZK=0.0 + DO 30 L=I1-I2+K,K-1 + ZK=ZK+ASS(KEY1+L)*VEC(L) + Z(L)=Z(L)+ASS(KEY1+L)*VEC(K) + 30 CONTINUE + Z(K)=ZK+ASS(KEY1+K)*VEC(K) + I1=I2+1 + 50 CONTINUE + RETURN +* +* CALCULATION OF Z=Z+(ASS-DIAG(ASS))*VEC. + 60 I1=MU1(1)+1 + DO 80 K=2,L4 + I2=MU1(K) + KEY1=I2-K + DO 70 L=I1-I2+K,K-1 + Z(K)=Z(K)+ASS(KEY1+L)*VEC(L) + Z(L)=Z(L)+ASS(KEY1+L)*VEC(K) + 70 CONTINUE + I1=I2+1 + 80 CONTINUE + RETURN + END diff --git a/Utilib/src/ALLDLS.f b/Utilib/src/ALLDLS.f new file mode 100644 index 0000000..4a5a7b8 --- /dev/null +++ b/Utilib/src/ALLDLS.f @@ -0,0 +1,70 @@ +*DECK ALLDLS + SUBROUTINE ALLDLS (L4,MU1,ASS,F) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solution of a symmetric linear system where the coefficient matrix +* have been factorized by a preceding call to ALLDLF. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* MU1 position of each diagonal element in vector ASS. +* ASS LDL(T) factors of the coefficient matrix in compressed +* diagonal storage mode. DIMENSION ASS(MU1(L4)-MU1(1)+1) +* F right-hand side of the linear system. +* +*Parameters: output +* F solution of the linear system. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4) + REAL ASS(*),F(L4) +* + IF (L4.EQ.1) GO TO 60 + K1=MU1(1)+1 + DO 20 I=2,L4 + K2=MU1(I) + KJ=I-K2+K1 + T=-F(I) + DO 10 K=K1,K2-1 + T=T+F(KJ)*ASS(K) + KJ=KJ+1 + 10 CONTINUE + K1=K2+1 + F(I)=-T + 20 CONTINUE +C + DO 30 I=1,L4 + F(I)=F(I)*ASS(MU1(I)) + 30 CONTINUE +C + K2=MU1(L4) + DO 50 I=L4,2,-1 + T=-F(I) + K1=MU1(I-1)+1 + KJ=I-K2+K1 + DO 40 K=K1,K2-1 + F(KJ)=F(KJ)+ASS(K)*T + KJ=KJ+1 + 40 CONTINUE + K2=K1-1 + 50 CONTINUE + RETURN +C + 60 F(1)=F(1)*ASS(MU1(1)) + RETURN + END diff --git a/Utilib/src/ALLUF.f b/Utilib/src/ALLUF.f new file mode 100644 index 0000000..2bd965b --- /dev/null +++ b/Utilib/src/ALLUF.f @@ -0,0 +1,103 @@ +*DECK ALLUF + SUBROUTINE ALLUF(L4,ASS,MU1,IMA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LU factorization of a general positive definite matrix in compressed +* diagonal storage mode. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* ASS coefficient matrix in compressed diagonal storage mode. +* A(I,J)=ASS(MU1(I)-I+J) if J.le.I and J.gt.I+IMA(I-1)-MU1(I) +* =ASS(MU1(J)+J-I) if I.le.J and I.ge.J-IMA(J)+MU1(J) +* =0.0 else +* DIMENSION ASS(IMA(L4)) +* MU1 position of each diagonal element in vector ASS. +* IMA position of the first non-zero column element in vector ASS. +* +*Parameters: output +* ASS LU factors. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4),IMA(L4) + REAL ASS(*) +* + DO 120 I=2,L4 + MU1IMI=MU1(I)-I + MU1IPI=MU1(I)+I + IND1=IMA(I-1)-MU1IMI+1 + IND2=MU1IPI-IMA(I) + IF (IND1.LE.IND2) THEN + DO 20 J=IND1,IND2-1 + MU1JPJ=MU1(J)+J + SUM=0.0 + DO 10 K=MAX(IND1,MU1JPJ-IMA(J)),J-1 + SUM=SUM+ASS(MU1IMI+K)*ASS(MU1JPJ-K) + 10 CONTINUE + ASS(MU1IMI+J)=ASS(MU1IMI+J)-SUM + 20 CONTINUE + DO 50 J=IND2,I-1 + MU1JMJ=MU1(J)-J + MU1JPJ=MU1(J)+J + SUM=0.0 + DO 30 K=MAX(IND1,MU1JPJ-IMA(J)),J-1 + SUM=SUM+ASS(MU1IMI+K)*ASS(MU1JPJ-K) + 30 CONTINUE + ASS(MU1IMI+J)=ASS(MU1IMI+J)-SUM + SUM=0.0 + IF(J.GT.1) THEN + DO 40 K=MAX(IND2,IMA(J-1)-MU1JMJ+1),J-1 + SUM=SUM+ASS(MU1JMJ+K)*ASS(MU1IPI-K) + 40 CONTINUE + ENDIF + ASS(MU1IPI-J)=(ASS(MU1IPI-J)-SUM)/ASS(MU1JMJ+J) + 50 CONTINUE + ELSE + DO 70 J=IND2,IND1-1 + MU1JMJ=MU1(J)-J + SUM=0.0 + IF(J.GT.1) THEN + DO 60 K=MAX(IND2,IMA(J-1)-MU1JMJ+1),J-1 + SUM=SUM+ASS(MU1JMJ+K)*ASS(MU1IPI-K) + 60 CONTINUE + ENDIF + ASS(MU1IPI-J)=(ASS(MU1IPI-J)-SUM)/ASS(MU1JMJ+J) + 70 CONTINUE + DO 100 J=IND1,I-1 + MU1JMJ=MU1(J)-J + MU1JPJ=MU1(J)+J + SUM=0.0 + DO 80 K=MAX(IND1,MU1JPJ-IMA(J)),J-1 + SUM=SUM+ASS(MU1IMI+K)*ASS(MU1JPJ-K) + 80 CONTINUE + ASS(MU1IMI+J)=ASS(MU1IMI+J)-SUM + SUM=0.0 + DO 90 K=MAX(IND2,IMA(J-1)-MU1JMJ+1),J-1 + SUM=SUM+ASS(MU1JMJ+K)*ASS(MU1IPI-K) + 90 CONTINUE + ASS(MU1IPI-J)=(ASS(MU1IPI-J)-SUM)/ASS(MU1JMJ+J) + 100 CONTINUE + ENDIF + SUM=0.0 + DO 110 K=MAX(IND1,IND2),I-1 + SUM=SUM+ASS(MU1IMI+K)*ASS(MU1IPI-K) + 110 CONTINUE + ASS(MU1IMI+I)=ASS(MU1IMI+I)-SUM + 120 CONTINUE + RETURN + END diff --git a/Utilib/src/ALLUM.f b/Utilib/src/ALLUM.f new file mode 100644 index 0000000..043eaaa --- /dev/null +++ b/Utilib/src/ALLUM.f @@ -0,0 +1,76 @@ +*DECK ALLUM + SUBROUTINE ALLUM(L4,ASS,VEC,Z,MU1,IMA,ITY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* multiplication of a general matrix in compressed diagonal storage +* mode by a vector. Z=ASS*VEC +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* ASS coefficient matrix in compressed diagonal storage mode. +* DIMENSION ASS(IMA(L4)) +* VEC vector to multiply. +* Z vector that will be added to the result if ITY=2. +* MU1 position of each diagonal element in vector ASS. +* IMA position of the first non-zero column element in vector ASS. +* ITY type of multiplication (ITY=1: Z=ASS*VEC; +* ITY=2: Z=Z+(ASS-DIAG(ASS))*VEC). +* +*Parameters: output +* Z solution of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4),IMA(L4),ITY + REAL ASS(*),VEC(L4),Z(L4) +* + GO TO (10,60),ITY +* +* CALCULATION OF Z=ASS*VEC. + 10 KEY1=MU1(1) + Z(1)=ASS(KEY1)*VEC(1) + DO 50 I=2,L4 + ZK=0.0 + DO 30 J=IMA(I-1)-MU1(I)+I+1,I + KEY1=KEY1+1 + ZK=ZK+ASS(KEY1)*VEC(J) + 30 CONTINUE + Z(I)=ZK + ZK=VEC(I) + DO 40 J=I-1,MU1(I)+I-IMA(I),-1 + KEY1=KEY1+1 + Z(J)=Z(J)+ASS(KEY1)*ZK + 40 CONTINUE + 50 CONTINUE + RETURN +* +* CALCULATION OF Z=Z+(ASS-DIAG(ASS))*VEC. + 60 KEY1=MU1(1) + DO 90 I=2,L4 + DO 70 J=IMA(I-1)-MU1(I)+I+1,I-1 + KEY1=KEY1+1 + Z(I)=Z(I)+ASS(KEY1)*VEC(J) + 70 CONTINUE + KEY1=KEY1+1 + ZK=VEC(I) + DO 80 J=I-1,MU1(I)+I-IMA(I),-1 + KEY1=KEY1+1 + Z(J)=Z(J)+ASS(KEY1)*ZK + 80 CONTINUE + 90 CONTINUE + RETURN + END diff --git a/Utilib/src/ALLUS.f b/Utilib/src/ALLUS.f new file mode 100644 index 0000000..0d4926a --- /dev/null +++ b/Utilib/src/ALLUS.f @@ -0,0 +1,62 @@ +*DECK ALLUS + SUBROUTINE ALLUS(L4,MU1,IMA,ASS,F) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solution of a linear system where the coefficient matrix have been +* factorized by a preceding call to ALLUF. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L4 order of the coefficient matrix. +* MU1 position of each diagonal element in vector ASS. +* IMA position of the first non-zero column element in vector ASS. +* ASS LU factors of the coefficient matrix in compressed diagonal +* storage mode. DIMENSION ASS(IMA(L4)) +* F right-hand side of the linear system. +* +*Parameters: output +* F solution of the linear system. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER L4,MU1(L4),IMA(L4) + REAL ASS(*),F(L4) +* + F(1)=F(1)/ASS(MU1(1)) + DO 20 I=2,L4 + K1=IMA(I-1)+1 + K2=MU1(I) + KJ=I-K2+K1 + T=-F(I) + DO 10 K=K1,K2-1 + T=T+F(KJ)*ASS(K) + KJ=KJ+1 + 10 CONTINUE + F(I)=-T/ASS(MU1(I)) + 20 CONTINUE +* + DO 40 I=L4,2,-1 + K1=IMA(I) + K2=MU1(I) + KJ=I-K1+K2 + T=-F(I) + DO 30 K=K1,K2+1,-1 + F(KJ)=F(KJ)+ASS(K)*T + KJ=KJ+1 + 30 CONTINUE + 40 CONTINUE + RETURN + END diff --git a/Utilib/src/ALNNLS.f b/Utilib/src/ALNNLS.f new file mode 100644 index 0000000..aa25a16 --- /dev/null +++ b/Utilib/src/ALNNLS.f @@ -0,0 +1,301 @@ +*DECK ALNNLS + SUBROUTINE ALNNLS(A,M,N,MP,NP,B,X,RNORM,MODE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* implementation of the nonnegative least square algorithm. +* +*Author(s): A. Miller +* +*Parameters: input +* A input rectangular matrix. +* M,N first/second mathematical dimension of matrix A. +* MP,NP first/second physical dimension of matrix A. +* B source M-vector. +* +*Parameters: output +* A product matrix, Q*A, where Q IS AN M x M orthogonal matrix +* generated implicitly by this subroutine. +* B product Q*B. +* X solution N-vector. +* RNORM Euclidean norm of the residual vector. +* MODE success-failure flag (1: the solution has been computed +* successfully; 2: the dimensions of the problem are +* inconsistent, either m.LE.0 or n.LE.0; 3: iteration count +* exceeded with more than 10*n iterations). +* +*Reference: +* Chen, Donghui; Plemmons, Robert J. (2009). Nonnegativity constraints +* in numerical analysis. Symposium on the Birth of Numerical Analysis. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER M, N, MP, NP, MODE + DOUBLE PRECISION A(MP,NP), B(M), X(N), RNORM +*---- +* Local variables +*---- + INTEGER I, II, IP, ITER, ITMAX, IZ, IZ1, IZ2, IZMAX, J, JJ, JZ, + > L, MDA, NPP1, NSETP + DOUBLE PRECISION DUMMY(1), ALPHA, ASAVE, CC, FACTOR, SM, SS, T, + > TEMP, UNORM, UP, WMAX, ZTEST, XR, YR + INTEGER, ALLOCATABLE, DIMENSION(:) :: INDX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: W, ZZ + PARAMETER(FACTOR = 0.01D0) +* + MODE = 1 + IF(M.LE.0 .OR. N.LE.0) THEN + MODE = 2 + RETURN + ENDIF + ITER = 0 + ITMAX = 10*N + ALLOCATE(INDX(N),W(N), ZZ(M)) +*---- +* Initialize the arrays INDX() and X(). +*---- + DO I = 1,N + X(I) = 0.0D0 + INDX(I) = I + ENDDO + IZ2 = N + IZ1 = 1 + NSETP = 0 + NPP1 = 1 +*---- +* ****** MAIN LOOP BEGINS HERE ****** +* Quit if all coefficients are already in the solution or if M cols of +* A have been triangularized. +*---- + 30 IF(IZ1.GT.IZ2 .OR. NSETP.GE.M) GO TO 350 +*---- +* Compute components of the dual (negative gradient) vector W. +*---- + DO IZ = IZ1,IZ2 + J = INDX(IZ) + W(J) = DOT_PRODUCT(A(NPP1:M,J), B(NPP1:M)) + ENDDO +*---- +* Find largest positive W(J). +*---- + 60 IZMAX = 0 + WMAX = 0.0D0 + DO IZ = IZ1,IZ2 + J = INDX(IZ) + IF(W(J).GT.WMAX) THEN + WMAX = W(J) + IZMAX = IZ + ENDIF + ENDDO +*---- +* If WMAX.le.0. go to termination. This indicates satisfaction of the +* Kuhn-Tucker conditions. +*---- + IF(WMAX.LE.0.0D0) GO TO 350 + IZ = IZMAX + J = INDX(IZ) +*---- +* The sign of W(J) is ok for J to be moved to set P. Begin the +* transformation and check new diagonal element to avoid near linear +* dependence. +*---- + ASAVE = A(NPP1,J) + CALL ALH12(1, NPP1, NPP1+1, M, A(:,J), UP, DUMMY(1), 1, 1, 0) + UNORM = 0.0D0 + IF(NSETP.NE.0) UNORM = SUM( A(1:NSETP,J)**2 ) + UNORM = SQRT(UNORM) + IF(UNORM + ABS(A(NPP1,J))*FACTOR - UNORM .GT. 0.0D0) THEN +*---- +* Col J is sufficiently independent. Copy B into ZZ, update ZZ +* and solve for ZTEST ( = proposed new value for X(J) ). +*---- + ZZ(1:M) = B(1:M) + CALL ALH12(2, NPP1, NPP1+1, M, A(:,J), UP, ZZ(1), 1, 1, 1) + ZTEST = ZZ(NPP1)/A(NPP1,J) +*---- +* See if ZTEST is positive. +*---- + IF(ZTEST.GT.0.0D0) GO TO 140 + ENDIF +*---- +* Reject J as a candidate to be moved from set Z to set P. Restore +* A(NPP1,J), set W(J) = 0., and loop back to test dual coeffs again. +*---- + A(NPP1,J) = ASAVE + W(J) = 0.0D0 + GO TO 60 +*---- +* The index J = INDX(IZ) has been selected to be moved from +* set Z to set P. Update B, update indices, apply Householder +* transformations to cols in new set Z, sero subdiagonal elts in +* col J, set W(J) = 0. +*---- + 140 B(1:M) = ZZ(1:M) + INDX(IZ) = INDX(IZ1) + INDX(IZ1) = J + IZ1 = IZ1+1 + NSETP = NPP1 + NPP1 = NPP1+1 + MDA = SIZE(A,1) + JJ = 0 + IF(IZ1.LE.IZ2) THEN + DO JZ = IZ1,IZ2 + JJ = INDX(JZ) + CALL ALH12(2, NSETP, NPP1, M, A(:,J), UP, A(1,JJ), 1, MDA, 1) + ENDDO + ENDIF + IF(NSETP.NE.M) A(NPP1:M,J) = 0.0D0 + W(J) = 0.0D0 +*---- +* Solve the triangular system. Store the solution temporarily in ZZ(). +*---- + DO L = 1, NSETP + IP = NSETP+1-L + IF(L .NE. 1) ZZ(1:IP) = ZZ(1:IP) - A(1:IP,JJ)*ZZ(IP+1) + JJ = INDX(IP) + ZZ(IP) = ZZ(IP) / A(IP,JJ) + ENDDO +*---- +* ****** SECONDARY LOOP BEGINS HERE ****** +*---- + 210 ITER = ITER+1 + IF(ITER.GT.ITMAX) THEN + MODE = 3 + WRITE (*,'(/A)') ' NNLS QUITTING ON ITERATION COUNT.' + GO TO 350 + ENDIF +*---- +* See if all new constrained coeffs are feasible; if not compute ALPHA. +*---- + ALPHA = 2.0D0 + DO IP = 1,NSETP + L = INDX(IP) + IF(ZZ(IP).LE.0.0D0) THEN + T = -X(L)/(ZZ(IP)-X(L)) + IF(ALPHA.GT.T) THEN + ALPHA = T + JJ = IP + ENDIF + ENDIF + ENDDO +*---- +* If all new constrained coeffs are feasible then ALPHA will still be +* equal to 2. If so exit from secondary loop to main loop. +*---- + IF(ALPHA == 2.0D0) GO TO 330 +*---- +* Otherwise use ALPHA which will be between 0. and 1. to interpolate +* between the old X and the new ZZ. +*---- + DO IP = 1,NSETP + L = INDX(IP) + X(L) = X(L) + ALPHA*(ZZ(IP)-X(L)) + ENDDO +*---- +* Modify A and B and the index arrays to move coefficient I from set +* P to set Z. +*---- + I = INDX(JJ) + 260 X(I) = 0.0D0 +*---- +* Compute.. matrix (C, S) so that (C, S)(A) = (SQRT(A**2+B**2)) +* (-S,C) (-S,C)(B) ( 0 ) +* Compute SIG = SQRT(A**2+B**2) +* SIG is computed last to allow for the possibility that SIG +* may be in the same location as A OR B . +*---- + IF(JJ.NE.NSETP) THEN + JJ = JJ+1 + DO J = JJ,NSETP + II = INDX(J) + INDX(J-1) = II + IF(ABS(A(J-1,II)).GT.ABS(A(J,II))) THEN + XR = A(J,II) / A(J-1,II) + YR = SQRT(1.0D0 + XR**2) + CC = SIGN(1.0D0/YR, A(J-1,II)) + SS = CC * XR + A(J-1,II) = ABS(A(J-1,II)) * YR + ELSE IF(A(J,II).NE.0.D0) THEN + XR = A(J-1,II) / A(J,II) + YR = SQRT(1.0D0 + XR**2) + SS = SIGN(1.0D0/YR, A(J,II)) + CC = SS * XR + A(J-1,II) = ABS(A(J,II)) * YR + ELSE + CC = 0.0D0 + SS = 1.0D0 + ENDIF + A(J,II) = 0.0D0 + DO L = 1,N + IF(L.NE.II) THEN +*---- +* Apply procedure G2 (CC,SS,A(J-1,L),A(J,L)) +*---- + TEMP = A(J-1,L) + A(J-1,L) = CC*TEMP + SS*A(J,L) + A(J,L) = -SS*TEMP + CC*A(J,L) + ENDIF + ENDDO +*---- +* Apply procedure G2 (CC,SS,B(J-1),B(J)) +*---- + TEMP = B(J-1) + B(J-1) = CC*TEMP + SS*B(J) + B(J) = -SS*TEMP + CC*B(J) + ENDDO + ENDIF + NPP1 = NSETP + NSETP = NSETP-1 + IZ1 = IZ1-1 + INDX(IZ1) = I +*---- +* See if the remaining coeffs in set P are feasible. They should be +* because of the way ALPHA was determined. if any are infeasible it is +* due to round-off error. any that are nonpositive will be set to 0.0d0 +* and moved from set P to set Z. +*---- + DO JJ = 1,NSETP + I = INDX(JJ) + IF(X(I).LE.0.0D0) GO TO 260 + ENDDO +*---- +* Copy B( ) into ZZ( ). Then solve again and loop back. +*---- + ZZ(1:M) = B(1:M) + DO L = 1, NSETP + IP = NSETP+1-L + IF(L .NE. 1) ZZ(1:IP) = ZZ(1:IP) - A(1:IP,JJ)*ZZ(IP+1) + JJ = INDX(IP) + ZZ(IP) = ZZ(IP) / A(IP,JJ) + ENDDO + GO TO 210 +*---- +* ****** End of secondary loop ****** +*---- + 330 DO IP = 1,NSETP + I = INDX(IP) + X(I) = ZZ(IP) + ENDDO +*---- +* All new coeffs are positive. Loop back to beginning. +*---- + GO TO 30 +*---- +* Come to here for termination. Compute the norm of the final residual +* vector. +*---- + 350 SM = 0.0D0 + IF(NPP1.LE.M) THEN + SM = SUM( B(NPP1:M)**2 ) + ELSE + W(1:N) = 0.0D0 + ENDIF + RNORM = SQRT(SM) + DEALLOCATE(ZZ,W,INDX) + RETURN + END diff --git a/Utilib/src/ALPADE.f b/Utilib/src/ALPADE.f new file mode 100644 index 0000000..fd0d42c --- /dev/null +++ b/Utilib/src/ALPADE.f @@ -0,0 +1,186 @@ +*DECK ALPADE + SUBROUTINE ALPADE(NORIN,X,Y,EPSRID,NOR,A,B,PREC,IER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* compute the polynomial coefficients of a Pade approximation using an +* inverse differences collocation. +* +*Copyright: +* Copyright (C) 1996 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NORIN 2*NORIN+1 is the number of collocation points. +* X abscissa of the collocation points. +* Y ordinates of the collocation points. +* EPSRID epsilon used in polynomial simplification. +* +*Parameters: output +* NOR order of the polynomials. +* A polynomial coefficients of the numerator of the Pade +* approximation. a(0) is the constant term. +* B polynomial coefficients of the denominator of the Pade +* approximation. b(0) is the constant term. +* DOUBLE PRECISION A(0:NOR),B(0:NOR) +* PREC accuracy of the fit. +* IER error flag (=0: no error; =1: negative pole removing). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NORIN,IER + REAL X(0:2*NORIN),Y(0:2*NORIN),PREC + DOUBLE PRECISION EPSRID,A(0:NORIN),B(0:NORIN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXNOR=10) + DOUBLE PRECISION DC(0:MAXNOR),DENOM,DY(0:2*MAXNOR,0:2*MAXNOR), + 1 ERR1,ERR2,GARINF,SCC,SDD + COMPLEX*16 DDA(0:MAXNOR-2),DDB(0:MAXNOR-2),SIGX0(MAXNOR), + 1 SIGXW(MAXNOR) + LOGICAL LINF,LFAIL +* + IER=0 + IF(NORIN.GT.MAXNOR) CALL XABORT('ALPADE: INSUFFICIENT MAXNOR.') + LINF=X(2*NORIN).GE.1.0E10 + JMAX=2*NORIN + ERR2=DBLE(Y(1)) + GARINF=0.0D0 + DY(0:2*MAXNOR,0:2*MAXNOR)=0.0D0 + DO 15 J=0,2*NORIN + IF(X(J).LE.0.0) CALL XABORT('ALPADE: ZERO OR NEGATIVE ABSCISSA.') + IF(Y(J).LE.0.0) CALL XABORT('ALPADE: ZERO OR NEGATIVE ORDINATE.') + ERR1=0.0D0 + DO 10 I=J,2*NORIN + IF(J.EQ.0) THEN + DY(I,J)=DBLE(Y(I)) + ELSE IF(LINF.AND.(MOD(J,2).EQ.1).AND.(I.EQ.2*NORIN)) THEN + DENOM=DY(I,J-1)-DY(J-1,J-1) + IF(DENOM.EQ.0.0) CALL XABORT('ALPADE: ALGORITHM FAILURE(1).') + DY(I,J)=1.0D0/DENOM + ELSE IF(LINF.AND.(I.EQ.2*NORIN)) THEN + DENOM=DY(I,J-1) + IF(DENOM.EQ.0.0) CALL XABORT('ALPADE: ALGORITHM FAILURE(2).') + DY(I,J)=1.0D0/DENOM + ELSE + DENOM=DY(I,J-1)-DY(J-1,J-1) + IF(DENOM.EQ.0.0) CALL XABORT('ALPADE: ALGORITHM FAILURE(3).') + DY(I,J)=(DBLE(X(I))-DBLE(X(J-1)))/DENOM + ENDIF + ERR1=MAX(ERR1,ABS(DY(I,J)-DY(J,J))) + 10 CONTINUE + IF(MOD(J,2).EQ.0) GARINF=GARINF+DY(J,J) + IF(LINF.AND.(ERR1.LE.1.0D-6*ERR2).AND.(ABS(GARINF-Y(2*NORIN)).LE. + 1 1.0D-5*ABS(GARINF))) THEN + JMAX=J + GO TO 20 + ENDIF + ERR2=ERR1 + 15 CONTINUE +* + 20 IF(MOD(JMAX,2).NE.0) CALL XABORT('ALPADE: ALGORITHM FAILURE(4).') + N=0 + MM=JMAX-1 + A(0)=DY(JMAX,JMAX) + B(0)=1.0D0 + NOR=JMAX/2 + DO 60 K=1,NOR + DC(0)=0.0D0 + DO 30 I=0,N + DC(I+1)=B(I) + DC(I)=DC(I)-B(I)*X(MM)+A(I)*DY(MM,MM) + 30 CONTINUE + MM=MM-1 + B(0)=0.0D0 + DO 40 I=0,N + B(I+1)=A(I) + B(I)=B(I)-A(I)*X(MM)+DC(I)*DY(MM,MM) + 40 CONTINUE + B(N+1)=B(I)+DC(N+1)*DY(MM,MM) + DO 50 I=0,N+1 + A(I)=B(I) + B(I)=DC(I) + 50 CONTINUE + MM=MM-1 + N=N+1 + 60 CONTINUE +* +* POLYNOMIAL SIMPLIFICATION. + DDA(0)=A(NOR) + DDB(0)=B(NOR) + IF(NOR.EQ.0) GO TO 120 + CALL ALROOT(A,NOR,SIGX0,LFAIL) + IF(LFAIL) CALL XABORT('ALPADE: POLYNOMIAL ROOT FINDING FAILURE.') + CALL ALROOT(B,NOR,SIGXW,LFAIL) + IF(LFAIL) CALL XABORT('ALPADE: POLYNOMIAL ROOT FINDING FAILURE.') + IJNOR=1 + 70 XXX=ABS(REAL(CMPLX(SIGXW(IJNOR)))-REAL(CMPLX(SIGX0(IJNOR)))) + IF(XXX.LT.EPSRID*ABS(SIGXW(IJNOR))) THEN + NOR=NOR-1 + DO 80 I=IJNOR,NOR + SIGX0(I)=SIGX0(I+1) + SIGXW(I)=SIGXW(I+1) + 80 CONTINUE + ELSE IF((DBLE(SIGXW(IJNOR)).GT.0.).AND.(DIMAG(SIGXW(IJNOR)).EQ.0.) + 1 ) THEN + IER=1 + NOR=NOR-1 + DO 90 I=IJNOR,NOR + SIGX0(I)=SIGX0(I+1) + SIGXW(I)=SIGXW(I+1) + 90 CONTINUE + ELSE + IJNOR=IJNOR+1 + ENDIF + IF(IJNOR.LE.NOR) GO TO 70 + IF(NOR.LT.0) CALL XABORT('ALPADE: ALGORITHM FAILURE(5).') + DO 110 I=1,NOR + DDA(I)=DDA(I-1) + DDB(I)=DDB(I-1) + DO 100 J=I-1,1,-1 + DDA(J)=DDA(J-1)-DDA(J)*SIGX0(I) + DDB(J)=DDB(J-1)-DDB(J)*SIGXW(I) + 100 CONTINUE + DDA(0)=-DDA(0)*SIGX0(I) + DDB(0)=-DDB(0)*SIGXW(I) + 110 CONTINUE + 120 DENOM=DBLE(DDB(NOR)) + DO 130 I=0,NOR + A(I)=DBLE(DDA(I))/DENOM + B(I)=DBLE(DDB(I))/DENOM + 130 CONTINUE +* +* TEST THE ACCURACY OF THE PADE APPROXIMATION. + PREC=0.0 + PREC1=0.0 + DO 150 I=0,2*NORIN + SCC=A(NOR) + SDD=B(NOR) + IF(X(I).LT.1.0E10) THEN + DO 140 INOR=NOR-1,0,-1 + SCC=A(INOR)+SCC*X(I) + SDD=B(INOR)+SDD*X(I) + 140 CONTINUE + ENDIF + PREC=MAX(PREC,ABS(REAL(SCC/SDD)/Y(I)-1.0)) + PREC1=MAX(PREC1,ABS(Y(2*NORIN)/Y(I)-1.0)) + 150 CONTINUE + IF((IER.NE.0).AND.(PREC.GT.0.99*PREC1)) THEN +* USE A UNIFORM REPRESENTATION. + NOR=0 + A(0)=DBLE(Y(2*NORIN)) + B(0)=1.0D0 + PREC=PREC1 + ENDIF + RETURN + END diff --git a/Utilib/src/ALPINV.f b/Utilib/src/ALPINV.f new file mode 100644 index 0000000..8544b2c --- /dev/null +++ b/Utilib/src/ALPINV.f @@ -0,0 +1,46 @@ +*DECK ALPINV + SUBROUTINE ALPINV(M,N,A,AINV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* pseudo inversion of a non singular matrix using Gaussian elimination +* with partial pivoting. Real version. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* M first dimension of matrix A. +* N second dimension of matrix A. +* A coefficient matrix to be inverted. +* +*Parameters: output +* AINV pseudo inverted matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER M,N + REAL A(M,N),AINV(N,M) +*---- +* LOCAL VARIABLES +*---- + REAL, DIMENSION(:,:), ALLOCATABLE :: B +* + ALLOCATE(B(N,N)) + B=MATMUL(TRANSPOSE(A),A) + CALL ALINV(N, B, N, IER) + IF(IER.NE.0) CALL XABORT('ALPINV: PSEUDO INVERSION FAILURE.') + AINV=MATMUL(B, TRANSPOSE(A)) + DEALLOCATE(B) + RETURN + END diff --git a/Utilib/src/ALPINVD.f b/Utilib/src/ALPINVD.f new file mode 100644 index 0000000..69b4bc5 --- /dev/null +++ b/Utilib/src/ALPINVD.f @@ -0,0 +1,47 @@ +*DECK ALPINVD + SUBROUTINE ALPINVD(M,N,A,AINV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* pseudo inversion of a non singular matrix using Gaussian elimination +* with partial pivoting. Double precision version. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* M first dimension of matrix A. +* N second dimension of matrix A. +* A coefficient matrix to be inverted. +* +*Parameters: output +* AINV pseudo inverted matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER M,N + DOUBLE PRECISION A(M,N),AINV(N,M) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: B +* + ALLOCATE(B(N,N)) + B=MATMUL(TRANSPOSE(A),A) + CALL ALINVD(N, B, N, IER) + IF(IER.NE.0) CALL XABORT('ALPINVD: PSEUDO INVERSION FAILURE.') + AINV=MATMUL(B, TRANSPOSE(A)) + DEALLOCATE(B) + RETURN + END diff --git a/Utilib/src/ALPLGN.f b/Utilib/src/ALPLGN.f new file mode 100644 index 0000000..8c1c030 --- /dev/null +++ b/Utilib/src/ALPLGN.f @@ -0,0 +1,63 @@ +*DECK ALPLGN + DOUBLE PRECISION FUNCTION ALPLGN(L,M,X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* return the Ferrer definition of the associated Legendre function. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L main index +* M secondary index +* X direction cosine +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + INTEGER L,M + DOUBLE PRECISION X + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPX +* + IF(M.LT.0) THEN + CALL XABORT('ALPLGN: BAD ARGUMENTS (1)') + ELSE IF(M.GT.L) THEN + CALL XABORT('ALPLGN: BAD ARGUMENTS (2)') + ELSE IF(ABS(X).GT.1.0D0) THEN + CALL XABORT('ALPLGN: BAD ARGUMENTS (3)') + ENDIF + PMM=1.0D0 + IF(M.GT.0) THEN + ALLOCATE(IPX(2*M)) + DO I=1,2*M + IPX(I)=I + ENDDO + PMM=PRODUCT(IPX,MASK=MOD(IPX,2)==1)*SQRT((1.0D0-X)*(1.0D0+X))**M + DEALLOCATE(IPX) + ENDIF + IF(L.EQ.M) THEN + ALPLGN=PMM + ELSE + PMMP1=(2*M+1)*X*PMM + IF(L.EQ.M+1) THEN + ALPLGN=PMMP1 + ELSE + PLL=0.0D0 + DO LL=M+2,L + PLL=((2*LL-1)*X*PMMP1-(LL+M-1)*PMM)/(LL-M) + PMM=PMMP1 + PMMP1=PLL + ENDDO + ALPLGN=PLL + ENDIF + ENDIF + RETURN + END diff --git a/Utilib/src/ALPLSF.f b/Utilib/src/ALPLSF.f new file mode 100644 index 0000000..53dc616 --- /dev/null +++ b/Utilib/src/ALPLSF.f @@ -0,0 +1,282 @@ +*DECK ALPLSF + SUBROUTINE ALPLSF(IMETH,N,X,Y,EPSRID,LREAL,NOR,A,B,PREC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* compute the polynomial coefficients of a Pade approximation using a +* direct least square procedure. +* +*Copyright: +* Copyright (C) 1996 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMETH type of algorithm (=1: use QR; =2: use SVD; =3: use NNLS). +* N number of collocation points. +* X abscissa of the collocation points. +* Y ordinates of the collocation points. +* EPSRID epsilon used in polynomial simplification. +* LREAL selection flag (=.true. to get rid of complex roots). +* +*Parameters: output +* NOR order of the polynomials. +* A polynomial coefficients of the numerator of the Pade +* approximation. A(0) is the constant term. +* B polynomial coefficients of the denominator of the Pade +* approximation. B(0) is the constant term. +* DOUBLE PRECISION A(0:NOR),B(0:NOR) +* PREC accuracy of the fit. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMETH,N,NOR + REAL X(N),Y(N),PREC + DOUBLE PRECISION EPSRID,A(0:(N-1)/2),B(0:(N-1)/2) + LOGICAL LREAL +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXNOR=10,MAXPTS=99) + DOUBLE PRECISION BB(MAXPTS),GAR,PARAM(MAXPTS),AGAR(0:MAXNOR), + 1 BGAR(0:MAXNOR),CGAR(0:MAXNOR+1),W(MAXPTS),RV1(MAXPTS),SGN, + 2 GAROLD,YAPPR,RNORM,RMAX + COMPLEX*16 SIGX0(MAXNOR+1),SIGXW(MAXNOR+1),DDAGAR(0:MAXNOR), + 1 DDBGAR(0:MAXNOR),WEIGH(MAXNOR+1),CC,DD,CCC,XCC,DCC + LOGICAL LFAIL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: AA,V +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(AA(MAXPTS,MAXPTS),V(MAXPTS,MAXPTS)) +* + IF(N.GT.MAXPTS) CALL XABORT('ALPLSF: INSUFFICIENT MAXPTS.') +* +* NOR=0 CASE. + GAROLD=0.0 + NOR=0 + PREC=0.0 + A(0)=DBLE(Y(N)) + B(0)=1.0D0 + DO 10 I=1,N-1 + PREC=MAX(PREC,ABS(Y(N)/Y(I)-1.0)) + 10 CONTINUE +* + RMAX=1.0D10 + DO 210 IINOR=1,MIN((N-1)/2,MAXNOR) + INOR=IINOR + IF(X(N).GE.0.99E10) THEN + DO 41 I=1,N-1 + GAR=1.0D0 + IOF=0 + DO 20 J=0,INOR-1 + IOF=IOF+1 + AA(I,IOF)=GAR + GAR=GAR*X(I) + 20 CONTINUE + GAR=1.0D0 + DO 30 J=0,INOR-1 + IOF=IOF+1 + GAROLD=GAR + AA(I,IOF)=-GAR*Y(I) + GAR=GAR*X(I) + 30 CONTINUE + BB(I)=(Y(I)-Y(N))*X(I) + DO 40 J=1,2*INOR + AA(I,J)=AA(I,J)/GAROLD + 40 CONTINUE + 41 CONTINUE + IF(IMETH.EQ.1) THEN + CALL ALST2F(MAXPTS,N-1,2*INOR,AA,RV1) + CALL ALST2S(MAXPTS,N-1,2*INOR,AA,RV1,BB,PARAM) + ELSE IF(IMETH.EQ.2) THEN + CALL ALSVDF(AA,N-1,2*INOR,MAXPTS,MAXPTS,W,V,RV1) + DO 45 J=1,2*INOR + IF(W(J).EQ.0.0D0) CALL XABORT('ALPLSF: SVD FAILURE(1).') + 45 CONTINUE + CALL ALSVDS(AA,W,V,N-1,2*INOR,MAXPTS,MAXPTS,BB,PARAM,RV1) + ELSE IF(IMETH.EQ.3) THEN + CALL ALNNLS(AA,N-1,2*INOR,MAXPTS,MAXPTS,BB,PARAM,RNORM,MODE) + IF(MODE.NE.1) CALL XABORT('ALPLSF: NNLS FAILURE(1).') + IF((INOR.GT.1).AND.(RNORM.GE.0.95D0*RMAX)) GO TO 210 + RMAX=RNORM + ENDIF + DO 50 I=0,INOR-1 + AGAR(I)=PARAM(I+1) + BGAR(I)=PARAM(INOR+1+I) + 50 CONTINUE + AGAR(INOR)=Y(N) + BGAR(INOR)=1.0D0 + ELSE + DO 81 I=1,N + GAR=1.0D0 + IOF=0 + DO 60 J=0,INOR + IOF=IOF+1 + AA(I,IOF)=GAR + GAR=GAR*X(I) + 60 CONTINUE + GAR=1.0D0 + DO 70 J=0,INOR-1 + IOF=IOF+1 + GAROLD=GAR + AA(I,IOF)=-GAR*Y(I) + GAR=GAR*X(I) + 70 CONTINUE + BB(I)=Y(I)*X(I) + DO 80 J=1,2*INOR+1 + AA(I,J)=AA(I,J)/GAROLD + 80 CONTINUE + 81 CONTINUE + IF(IMETH.EQ.1) THEN + CALL ALST2F(MAXPTS,N,2*INOR+1,AA,RV1) + CALL ALST2S(MAXPTS,N,2*INOR+1,AA,RV1,BB,PARAM) + ELSE IF(IMETH.EQ.2) THEN + CALL ALSVDF(AA,N,2*INOR+1,MAXPTS,MAXPTS,W,V,RV1) + DO 85 J=1,2*INOR + IF(W(J).EQ.0.0D0) CALL XABORT('ALPLSF: SVD FAILURE(2).') + 85 CONTINUE + CALL ALSVDS(AA,W,V,N,2*INOR+1,MAXPTS,MAXPTS,BB,PARAM,RV1) + ELSE IF(IMETH.EQ.3) THEN + CALL ALNNLS(AA,N,2*INOR+1,MAXPTS,MAXPTS,BB,PARAM,RNORM,MODE) + IF(MODE.NE.1) CALL XABORT('ALPLSF: NNLS FAILURE(2).') + IF((INOR.GT.1).AND.(RNORM.GE.0.95D0*RMAX)) GO TO 210 + RMAX=RNORM + ENDIF + DO 90 I=0,INOR + AGAR(I)=PARAM(I+1) + IF(I.EQ.INOR) THEN + BGAR(I)=1.0D0 + ELSE + BGAR(I)=PARAM(INOR+2+I) + ENDIF + 90 CONTINUE + ENDIF +* +* POLYNOMIAL SIMPLIFICATION. + DDAGAR(0)=AGAR(INOR) + DDBGAR(0)=BGAR(INOR) + CALL ALROOT(AGAR(0:INOR),INOR,SIGX0,LFAIL) + IF(LFAIL) GO TO 210 + CALL ALROOT(BGAR(0:INOR),INOR,SIGXW,LFAIL) + IF(LFAIL) GO TO 210 + IJINOR=1 + 95 XXX=REAL(ABS(DBLE(SIGXW(IJINOR))-DBLE(SIGX0(IJINOR)))) + IF(XXX.LT.EPSRID*ABS(DBLE(SIGXW(IJINOR)))) THEN + INOR=INOR-1 + DO 100 I=IJINOR,INOR + SIGX0(I)=SIGX0(I+1) + SIGXW(I)=SIGXW(I+1) + 100 CONTINUE + ELSE IF((DBLE(SIGXW(IJINOR)).GT.EPSRID).AND. + > (DIMAG(SIGXW(IJINOR)).EQ.0.0).AND. + > (IMETH.EQ.3)) THEN + CALL XABORT('ALPLSF: NNLS FAILURE(3).') + ELSE IF((DBLE(SIGXW(IJINOR)).GT.0.1*EPSRID).AND. + > (DIMAG(SIGXW(IJINOR)).EQ.0.0)) THEN + GO TO 210 + ELSE + IJINOR=IJINOR+1 + ENDIF + IF(IJINOR.LE.INOR) GO TO 95 + IF(INOR.LT.0) CALL XABORT('ALPLSF: ALGORITHM FAILURE.') + DO 120 I=1,INOR + DDAGAR(I)=DDAGAR(I-1) + DDBGAR(I)=DDBGAR(I-1) + DO 110 J=I-1,1,-1 + DDAGAR(J)=DDAGAR(J-1)-DDAGAR(J)*SIGX0(I) + DDBGAR(J)=DDBGAR(J-1)-DDBGAR(J)*SIGXW(I) + 110 CONTINUE + DDAGAR(0)=-DDAGAR(0)*SIGX0(I) + DDBGAR(0)=-DDBGAR(0)*SIGXW(I) + 120 CONTINUE + DO 130 I=0,INOR + AGAR(I)=DBLE(DDAGAR(I))/DBLE(DDBGAR(INOR)) + BGAR(I)=DBLE(DDBGAR(I))/DBLE(DDBGAR(INOR)) + IF(AGAR(I).LE.0.0D0) GO TO 210 + IF(BGAR(I).LE.0.0D0) GO TO 210 + 130 CONTINUE + SGN=1.0D0 + CGAR(0)=AGAR(0) + DO 135 I=2,INOR+1 + SGN=-SGN + CGAR(I-1)=SGN*(BGAR(I-2)+AGAR(I-1)) + 135 CONTINUE + CGAR(INOR+1)=-SGN + CALL ALROOT(CGAR(0:INOR+1),INOR+1,SIGX0,LFAIL) + IF(LFAIL) GO TO 210 +* +* NEWTON IMPROVEMENT OF THE ROOTS. + DO 138 I=1,INOR+1 + CCC=0.0D0 + XCC=1.0D0 + DO 136 J=0,INOR+1 + CCC=CCC+CGAR(J)*XCC + XCC=XCC*SIGX0(I) + 136 CONTINUE + DCC=0.0D0 + XCC=1.0D0 + DO 137 J=1,INOR+1 + DCC=DCC+CGAR(J)*XCC*REAL(J) + XCC=XCC*SIGX0(I) + 137 CONTINUE + SIGX0(I)=SIGX0(I)-CCC/DCC + 138 CONTINUE +* + IF(LREAL) THEN + DO 140 I=1,INOR+1 + IF(DBLE(SIGX0(I)).LT.1.0E-10) GO TO 210 + IF(DIMAG(SIGX0(I)).NE.0.0) GO TO 210 + 140 CONTINUE + ENDIF +* +* COMPUTE THE WEIGHTS. + DO 170 I=1,INOR+1 + CC=(1.0D0,0.0D0) + DD=0.0D0 + DO 150 JNOR=0,INOR + DD=DD+BGAR(JNOR)*CC + CC=-CC*SIGX0(I) + 150 CONTINUE + DO 160 J=1,INOR+1 + IF(J.NE.I) DD=DD/(SIGX0(J)-SIGX0(I)) + 160 CONTINUE + WEIGH(I)=DD + 170 CONTINUE +* +* TEST THE ACCURACY OF THE PADE APPROXIMATION. + PREC1=0.0 + DO 190 I=1,N + CC=0.0D0 + DD=0.0D0 + DO 180 JNOR=1,INOR+1 + CC=CC+WEIGH(JNOR)/(SIGX0(JNOR)+X(I)) + DD=DD+WEIGH(JNOR)*SIGX0(JNOR)/(SIGX0(JNOR)+X(I)) + 180 CONTINUE + YAPPR=DBLE(DD/CC) + PREC1=MAX(PREC1,ABS(REAL(YAPPR)/Y(I)-1.0)) + 190 CONTINUE +* + IF(PREC1.LT.0.95*PREC) THEN + NOR=INOR + PREC=PREC1 + DO 200 I=0,NOR + A(I)=AGAR(I) + B(I)=BGAR(I) + 200 CONTINUE + ENDIF + 210 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(V,AA) + RETURN + END diff --git a/Utilib/src/ALPRTB.f b/Utilib/src/ALPRTB.f new file mode 100644 index 0000000..068066c --- /dev/null +++ b/Utilib/src/ALPRTB.f @@ -0,0 +1,157 @@ +*DECK ALPRTB + SUBROUTINE ALPRTB(NOR,IINI,DEMT,IER,WEIGHT,BASEPT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* compute a probability table preserving 2*NOR moments of a function +* using the modified Ribon approach. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NOR the number of moments to preserve is 2*NOR. +* IINI minimum order of the moment we want to preserve. we must +* have 2-2*NOR <= IINI <= 0 (order 0 and 1 moments are always +* preserved). +* DEMT moments. +* +*Parameters: output +* IER error flag (=0/=1 success/failure of the algorithm). +* WEIGHT weights of the probability table. +* BASEPT base points of the probability table. +* +*----------------------------------------------------------------------- +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NOR,IINI,IER + DOUBLE PRECISION DEMT(IINI:2*NOR+IINI-1) + REAL WEIGHT(NOR),BASEPT(NOR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXNOR=20) + DOUBLE PRECISION DS(MAXNOR+1,MAXNOR+1),DDA(0:MAXNOR),DD,DSIGX + COMPLEX*16 ROOTS(MAXNOR),CCC,DCC,XCC + COMPLEX CGAR + LOGICAL LFAIL +* + IF(NOR.GT.MAXNOR) CALL XABORT('ALPRTB: STORAGE OVERFLOW.') + IF(NOR.LE.0) CALL XABORT('ALPRTB: NEGATIVE OR ZERO VALUE OF NOR.') + IF((2-2*NOR.GT.IINI).OR.(IINI.GT.0)) CALL XABORT('ALPRTB: INCONSI' + 1 //'STENT VALUE OF IINI.') +* +* BUILD THE MATRIX. + DO 15 IOR=1,NOR + DS(IOR,NOR+1)=-DEMT(NOR+IOR+IINI-1) + DO 10 JOR=1,IOR + DS(IOR,JOR)=DEMT(IOR+JOR+IINI-2) + DS(JOR,IOR)=DEMT(IOR+JOR+IINI-2) + 10 CONTINUE + 15 CONTINUE +* +* L-D-L(T) FACTORIZATION OF THE MATRIX. + DO 40 I=1,NOR + DO 30 J=1,I-1 + DS(J,I)=DS(I,J) + DO 20 K=1,J-1 + DS(J,I)=DS(J,I)-DS(K,I)*DS(J,K) + 20 CONTINUE + DS(I,J)=DS(J,I)*DS(J,J) + DS(I,I)=DS(I,I)-DS(J,I)*DS(I,J) + 30 CONTINUE + IF(DS(I,I).EQ.0.D0) THEN + IER=1 + RETURN + ENDIF + DS(I,I)=1.D0/DS(I,I) + 40 CONTINUE +* +* SOLUTION OF THE FACTORIZED SYSTEM TO OBTAIN THE DENOMINATOR OF THE +* PADE APPROXIMATION. + DO 55 I=1,NOR + DO 50 K=1,I-1 + DS(I,NOR+1)=DS(I,NOR+1)-DS(I,K)*DS(K,NOR+1) + 50 CONTINUE + 55 CONTINUE + DO 60 I=1,NOR + DS(I,NOR+1)=DS(I,NOR+1)*DS(I,I) + 60 CONTINUE + DO 71 I=NOR,1,-1 + DO 70 K=I+1,NOR + DS(I,NOR+1)=DS(I,NOR+1)-DS(K,I)*DS(K,NOR+1) + 70 CONTINUE + 71 CONTINUE + DS(NOR+1,NOR+1)=1.0D0 +* +* COMPUTE THE BASE POINTS AS THE ROOTS OF THE DENOMINATOR. + CALL ALROOT(DS(1,NOR+1),NOR,ROOTS,LFAIL) + IF(LFAIL) CALL XABORT('ALPRTB: POLYNOMIAL ROOT FINDING FAILURE.') + DO 80 I=1,NOR +* +* NEWTON IMPROVEMENT OF THE ROOTS. + CCC=0.0D0 + XCC=1.0D0 + DO 74 J=0,NOR + CCC=CCC+DS(J+1,NOR+1)*XCC + XCC=XCC*ROOTS(I) + 74 CONTINUE + DCC=0.0D0 + XCC=1.0D0 + DO 75 J=1,NOR + DCC=DCC+DS(J+1,NOR+1)*XCC*REAL(J) + XCC=XCC*ROOTS(I) + 75 CONTINUE + ROOTS(I)=ROOTS(I)-CCC/DCC +* + CGAR=CMPLX(ROOTS(I)) + IF(ABS(AIMAG(CGAR)).GT.1.0E-4*ABS(REAL(CGAR))) THEN + IER=1 + RETURN + ELSE + BASEPT(I)=REAL(CMPLX(ROOTS(I))) + ENDIF + 80 CONTINUE +* +* COMPUTE THE WEIGHTS. + DO 130 I=1,NOR + DSIGX=DBLE(ROOTS(I)) + DDA(0)=1.0D0 + J0=0 + DO 100 J=1,NOR + IF(J.EQ.I) GO TO 100 + J0=J0+1 + DDA(J0)=DDA(J0-1) + DO 90 K=1,J0-1 + DDA(J0-K)=DDA(J0-K-1)-DDA(J0-K)*DBLE(ROOTS(J)) + 90 CONTINUE + DDA(0)=-DDA(0)*DBLE(ROOTS(J)) + 100 CONTINUE + DD=0.0D0 + DO 110 J=0,NOR-1 + DD=DD+DDA(J)*DEMT((IINI-1)/2+J) + 110 CONTINUE + DO 120 J=1,NOR + IF(J.NE.I) DD=DD/(DBLE(ROOTS(J))-DSIGX) + 120 CONTINUE + WEIGHT(I)=REAL(((-1.0D0)**(NOR-1))*DD*DSIGX**((1-IINI)/2)) + 130 CONTINUE +* +* TEST THE CONSISTENCY OF THE SOLUTION. + DO 140 I=1,NOR + IF((WEIGHT(I).LE.0.0).OR.(BASEPT(I).LE.0.0)) THEN + IER=1 + RETURN + ENDIF + 140 CONTINUE + IER=0 + RETURN + END diff --git a/Utilib/src/ALQUAR.f b/Utilib/src/ALQUAR.f new file mode 100644 index 0000000..0dcbf41 --- /dev/null +++ b/Utilib/src/ALQUAR.f @@ -0,0 +1,237 @@ +*DECK ALQUAR + SUBROUTINE ALQUAR(A,ROOTS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* compute the roots of the real quartic polynomial defined as +* A(1)+A(2)*Z + ... + A(5)*Z**4. +* NOTE: It is assumed that A(5) is non-zero. No test is made here. +* +*Author(s): A. H. Morris, W. L. Davis, A. Miller, and R. L. Carmichael +* +*Parameters: input +* A polynomial coefficients +* +*Parameters: output +* ROOTS complex roots +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + DOUBLE PRECISION, INTENT(IN) :: A(5) + COMPLEX*16, INTENT(OUT) :: ROOTS(4) +*---- +* LOCAL VARIABLES +*---- + INTEGER :: I, J + INTEGER,DIMENSION(1) :: K + DOUBLE PRECISION :: B, B2, C, D, E, H, P, Q, R, T, WORK, U, V, + > V1, V2, X, XX(3), Y, BQ, CQ, DQ, AA, BB + COMPLEX*16 :: W, AAA, BBB, SQ1, TEST, SQRTM3 + DOUBLE PRECISION,DIMENSION(4) :: TEMP + PARAMETER (SQRTM3=(0.0,1.73205080756888)) +* + IF(A(1)==0.0) THEN + IF(A(2).EQ.0.0) THEN + CQ=A(4)/A(5) + DQ=A(3)/A(5) + AAA=CQ*CQ-4.0D0*DQ + AAA=SQRT(AAA) + ROOTS(1)=0.0 + ROOTS(2)=0.0 + ROOTS(3)=-0.5D0*(CQ+AAA) + ROOTS(4)=-0.5D0*(CQ-AAA) + ELSE + BQ=A(4)/A(5) + CQ=A(3)/A(5) + DQ=A(2)/A(5) + AA=(3.0D0*CQ-BQ**2)/3.0D0 + BB=(2.0D0*BQ**3-9.0D0*BQ*CQ+27.0D0*DQ)/27.0D0 + SQ1=BB**2/4.0D0+AA**3/27.0D0 + TEST=BB/2.0D0-SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + AAA=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + AAA=-(TEST)**(1.0D0/3.0D0) + ELSE + AAA=(-TEST)**(1.0D0/3.0D0) + ENDIF + TEST=BB/2.0D0+SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + BBB=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + BBB=-(TEST)**(1.0D0/3.0D0) + ELSE + BBB=(-TEST)**(1.0D0/3.0D0) + ENDIF + ROOTS(1)=0.0 + ROOTS(2)=AAA+BBB-BQ/3.0D0 + ROOTS(3)=-(AAA+BBB)/2.0D0+(AAA-BBB)*SQRTM3/2.0D0-BQ/3.0D0 + ROOTS(4)=-(AAA+BBB)/2.0D0-(AAA-BBB)*SQRTM3/2.0D0-BQ/3.0D0 + ENDIF + RETURN + ENDIF +*---- +* Solve a quartic equation +*---- + B = A(4)/(4.0D0*A(5)) + C = A(3)/A(5) + D = A(2)/A(5) + E = A(1)/A(5) + B2 = B*B + + P = 0.5D0*(C - 6.0D0*B2) + Q = D - 2.0D0*B*(C - 4.0D0*B2) + R = B2*(C - 3.0D0*B2) - B*D + E +*---- +* Solve the resolvent cubic equation. the cubic has at least one +* nonnegative real root. if W1, W2, W3 are the roots of the cubic +* then the roots of the original equation are +* ROOTS = -B + CSQRT(W1) + CSQRT(W2) + CSQRT(W3) +* where the signs of the square roots are chosen so +* that CSQRT(W1) * CSQRT(W2) * CSQRT(W3) = -Q/8. +*---- + TEMP(1) = -Q*Q/64.0D0 + TEMP(2) = 0.25D0*(P*P - R) + TEMP(3) = P + TEMP(4) = 1.0D0 + BQ=TEMP(3) + CQ=TEMP(2) + DQ=TEMP(1) + AA=(3.0D0*CQ-BQ**2)/3.0D0 + BB=(2.0D0*BQ**3-9.0D0*BQ*CQ+27.0D0*DQ)/27.0D0 + SQ1=BB**2/4.0D0+AA**3/27.0D0 + TEST=BB/2.0D0-SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + AAA=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + AAA=-(TEST)**(1.0D0/3.0D0) + ELSE + AAA=(-TEST)**(1.0D0/3.0D0) + ENDIF + TEST=BB/2.0D0+SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + BBB=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + BBB=-(TEST)**(1.0D0/3.0D0) + ELSE + BBB=(-TEST)**(1.0D0/3.0D0) + ENDIF + ROOTS(1)=AAA+BBB-BQ/3.0D0 + ROOTS(2)=-(AAA+BBB)/2.0D0+(AAA-BBB)*SQRTM3/2.0D0-BQ/3.0D0 + ROOTS(3)=-(AAA+BBB)/2.0D0-(AAA-BBB)*SQRTM3/2.0D0-BQ/3.0D0 + IF(AIMAG(ROOTS(2)).NE.0.0D0) GO TO 60 +*---- +* The resolvent cubic has only real roots. +* Reorder the roots in increasing order. +*---- + XX(1) = DBLE(ROOTS(1)) + XX(2) = DBLE(ROOTS(2)) + XX(3) = DBLE(ROOTS(3)) + DO 25 J=2,3 + X=XX(J) + DO 10 I=J-1,1,-1 + IF(XX(I).LE.X) GOTO 20 + XX(I+1)=XX(I) + 10 CONTINUE + I=0 + 20 XX(I+1)=X + 25 CONTINUE + + U = 0.0D0 + IF(XX(3).GT.0.0D0) U = SQRT(XX(3)) + IF(XX(2).LE.0.0D0) GO TO 41 + IF(XX(1).GE.0.0D0) GO TO 30 + IF(ABS(XX(1)).GT.XX(2)) GO TO 40 + XX(1) = 0.0D0 + + 30 XX(1) = SQRT(XX(1)) + XX(2) = SQRT(XX(2)) + IF(Q.GT.0.0D0) XX(1) = -XX(1) + TEMP(1) = (( XX(1) + XX(2)) + U) - B + TEMP(2) = ((-XX(1) - XX(2)) + U) - B + TEMP(3) = (( XX(1) - XX(2)) - U) - B + TEMP(4) = ((-XX(1) + XX(2)) - U) - B + + DO J=1,3 + K=MINLOC(TEMP(J:)) + IF(J.NE.K(1)) THEN + WORK = TEMP(J) + TEMP(J) = TEMP(K(1)) + TEMP(K(1)) = WORK + ENDIF + ENDDO + + IF(ABS(TEMP(1)).GE.0.1D0*ABS(TEMP(4))) GO TO 31 + T = TEMP(2)*TEMP(3)*TEMP(4) + IF(T.NE.0.0D0) TEMP(1) = E/T + 31 ROOTS(1) = CMPLX(TEMP(1), 0.0D0, KIND=KIND(ROOTS)) + ROOTS(2) = CMPLX(TEMP(2), 0.0D0, KIND=KIND(ROOTS)) + ROOTS(3) = CMPLX(TEMP(3), 0.0D0, KIND=KIND(ROOTS)) + ROOTS(4) = CMPLX(TEMP(4), 0.0D0, KIND=KIND(ROOTS)) + RETURN + + 40 V1 = SQRT(ABS(XX(1))) + V2 = 0.0D0 + GO TO 50 + 41 V1 = SQRT(ABS(XX(1))) + V2 = SQRT(ABS(XX(2))) + IF(Q < 0.0D0) U = -U + + 50 X = -U - B + Y = V1 - V2 + ROOTS(1) = CMPLX(X, Y, KIND=KIND(ROOTS)) + ROOTS(2) = CMPLX(X,-Y, KIND=KIND(ROOTS)) + X = U - B + Y = V1 + V2 + ROOTS(3) = CMPLX(X, Y, KIND=KIND(ROOTS)) + ROOTS(4) = CMPLX(X,-Y, KIND=KIND(ROOTS)) + RETURN +*---- +* The resolvent cubic has complex roots. +*---- + 60 T = DBLE(ROOTS(1)) + X = 0.0D0 + IF(T < 0.0D0) THEN + GO TO 61 + ELSE IF(T.EQ.0.0D0) THEN + GO TO 70 + ELSE + GO TO 62 + ENDIF + 61 H = ABS(DBLE(ROOTS(2))) + ABS(AIMAG(ROOTS(2))) + IF(ABS(T).LE.H) GO TO 70 + GO TO 80 + 62 X = SQRT(T) + IF(Q.GT.0.0D0) X = -X + + 70 W = SQRT(ROOTS(2)) + U = 2.0D0*DBLE(W) + V = 2.0D0*ABS(AIMAG(W)) + T = X - B + XX(1) = T + U + XX(2) = T - U + IF(ABS(XX(1)).LE.ABS(XX(2))) GO TO 71 + T = XX(1) + XX(1) = XX(2) + XX(2) = T + 71 U = -X - B + H = U*U + V*V + IF(XX(1)*XX(1) < 0.01D0*MIN(XX(2)*XX(2),H)) XX(1) = E/(XX(2)*H) + ROOTS(1) = CMPLX(XX(1), 0.0D0, KIND=KIND(ROOTS)) + ROOTS(2) = CMPLX(XX(2), 0.0D0, KIND=KIND(ROOTS)) + ROOTS(3) = CMPLX(U, V, KIND=KIND(ROOTS)) + ROOTS(4) = CMPLX(U,-V, KIND=KIND(ROOTS)) + RETURN + + 80 V = SQRT(ABS(T)) + ROOTS(1) = CMPLX(-B, V, KIND=KIND(ROOTS)) + ROOTS(2) = CMPLX(-B,-V, KIND=KIND(ROOTS)) + ROOTS(3) = ROOTS(1) + ROOTS(4) = ROOTS(2) + RETURN + END diff --git a/Utilib/src/ALROOT.f b/Utilib/src/ALROOT.f new file mode 100644 index 0000000..0d65793 --- /dev/null +++ b/Utilib/src/ALROOT.f @@ -0,0 +1,132 @@ +*DECK ALROOT + SUBROUTINE ALROOT(A,M,ROOTS,LFAIL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* find the roots of a polynomial. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* A polynomial coefficients. +* M polynomial order. +* +*Parameters: output +* ROOTS complex roots. +* LFAIL flag set to .true. in case of failure. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER M + DOUBLE PRECISION A(M+1) + COMPLEX*16 ROOTS(M) + LOGICAL LFAIL +*---- +* LOCAL VARIABLES +*---- + COMPLEX*16 AAA,BBB,SQ1,TEST,SQRTM3 + PARAMETER (SQRTM3=(0.0,1.73205080756888)) + DOUBLE PRECISION EPS + PARAMETER (EPS=1.D-6,MAXM=101) + COMPLEX*16 AD(MAXM),X,B,C +* + LFAIL=.FALSE. + IF(M+1.GT.MAXM) CALL XABORT('ALROOT: INSUFFICIENT STORAGE.') + IF(A(M+1).EQ.0.0D0) CALL XABORT('ALROOT: INVALID COEFFICIENT.') + IF(M.EQ.1) THEN + ROOTS(1)=-A(1)/A(2) + ELSE IF(M.EQ.2) THEN + CQ=A(2)/A(3) + DQ=A(1)/A(3) + AAA=CQ*CQ-4.0D0*DQ + AAA=SQRT(AAA) + ROOTS(1)=-0.5D0*(CQ+AAA) + ROOTS(2)=-0.5D0*(CQ-AAA) + ELSE IF(M.EQ.3) THEN + IF(A(1).EQ.0.0) THEN + CQ=A(3)/A(4) + DQ=A(2)/A(4) + AAA=CQ*CQ-4.0D0*DQ + AAA=SQRT(AAA) + ROOTS(1)=0.0 + ROOTS(2)=-0.5D0*(CQ+AAA) + ROOTS(3)=-0.5D0*(CQ-AAA) + ELSE + BQ=A(3)/A(4) + CQ=A(2)/A(4) + DQ=A(1)/A(4) + AA=(3.0D0*CQ-BQ**2)/3.0D0 + BB=(2.0D0*BQ**3-9.0D0*BQ*CQ+27.0D0*DQ)/27.0D0 + SQ1=BB**2/4.0D0+AA**3/27.0D0 + TEST=BB/2.0D0-SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + AAA=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + AAA=-(TEST)**(1.0D0/3.0D0) + ELSE + AAA=(-TEST)**(1.0D0/3.0D0) + ENDIF + TEST=BB/2.0D0+SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + BBB=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + BBB=-(TEST)**(1.0D0/3.0D0) + ELSE + BBB=(-TEST)**(1.0D0/3.0D0) + ENDIF + ROOTS(1)=AAA+BBB-BQ/3.0D0 + ROOTS(2)=-(AAA+BBB)/2.0D0+(AAA-BBB)*SQRTM3/2.0D0-BQ/3.0D0 + ROOTS(3)=-(AAA+BBB)/2.0D0-(AAA-BBB)*SQRTM3/2.0D0-BQ/3.0D0 + ENDIF + ELSE IF(M.EQ.4) THEN + CALL ALQUAR(A,ROOTS) + ELSE + DO 10 J=1,M+1 + AD(J)=CMPLX(A(J),0.D0,KIND=KIND(AD)) + 10 CONTINUE + DO 25 J=M,1,-1 + X=CMPLX(0.D0,0.D0,KIND=KIND(X)) + CALL ALGUER(AD,J,X,ITS,LFAIL) + IF(LFAIL) RETURN + IF(ABS(DIMAG(X)).LE.2.D0*EPS**2*ABS(DBLE(X))) + 1 X=CMPLX(DBLE(X),0.D0,KIND=KIND(X)) + ROOTS(J)=X + B=AD(J+1) + DO 20 JJ=J,1,-1 + C=AD(JJ) + AD(JJ)=B + B=X*B+C + 20 CONTINUE + 25 CONTINUE + DO 30 J=1,M+1 + AD(J)=CMPLX(A(J),0.D0,KIND=KIND(AD)) + 30 CONTINUE + DO 40 J=1,M + CALL ALGUER(AD,M,ROOTS(J),ITS,LFAIL) + IF(LFAIL) RETURN + 40 CONTINUE + ENDIF +* + DO 70 J=2,M + X=ROOTS(J) + DO 50 I=J-1,1,-1 + IF(DBLE(ROOTS(I)).LE.DBLE(X)) GOTO 60 + ROOTS(I+1)=ROOTS(I) + 50 CONTINUE + I=0 + 60 ROOTS(I+1)=X + 70 CONTINUE + RETURN + END diff --git a/Utilib/src/ALSB.f b/Utilib/src/ALSB.f new file mode 100644 index 0000000..5075505 --- /dev/null +++ b/Utilib/src/ALSB.f @@ -0,0 +1,91 @@ +*DECK ALSB + SUBROUTINE ALSB (N,IS,B,IER,MAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solution of a system of linear equations using gaussian elimination +* with partial pivoting. Simple precision version. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N order of the coefficient matrix. +* IS number of right hand vectors. +* B coefficient matrix augmented with the right hand vectors. +* DIMENSION B(MAX,N+IS) +* MAX first dimention of matrix B. +* +*Parameters: output +* B solution vectors, starting at B(1,N+1). +* IER error flag. Execution failure if IER.ne.0. +* +*----------------------------------------------------------------------- +* + DIMENSION B(MAX,*) + IN=0 + M=N+IS + IER=0 + IF (N.EQ.1) GO TO 100 +* +* SEARCH FOR MAXIMUM PIVOT ON COLUMN JCOL. + NM1=N-1 + NP1=N+1 + DO 60 JCOL=1,NM1 + TEST=0.0 + DO 10 I=JCOL,N + IF (ABS(B(I,JCOL)).LE.TEST) GO TO 10 + TEST=ABS(B(I,JCOL)) + IN=I +10 CONTINUE + IF (TEST.EQ.0.0) GO TO 120 +* +* TRIANGULARIZATION. + PMX=B(IN,JCOL) + B(IN,JCOL)=B(JCOL,JCOL) + IP1=JCOL+1 + DO 50 J=IP1,M + PER=B(IN,J)/PMX + B(IN,J)=B(JCOL,J) + B(JCOL,J)=PER + DO 40 I=IP1,N + B(I,J)=B(I,J)-B(I,JCOL)*PER +40 CONTINUE +50 CONTINUE +60 CONTINUE + PER=B(N,N) + IF (PER.EQ.0.0) GO TO 120 + DO 70 J=NP1,M + B(N,J)=B(N,J)/PER +70 CONTINUE +* +* BACK SUBSTITUTION. + DO 95 IN=2,N + I=N-IN+1 + IP1=I+1 + DO 90 J=NP1,M + PER=B(I,J) + DO 80 K=IP1,N + PER=PER-B(I,K)*B(K,J) +80 CONTINUE + B(I,J)=PER +90 CONTINUE +95 CONTINUE + RETURN +* +100 PER=B(1,1) + IF (PER.EQ.0.0) GO TO 120 + DO 110 J=2,M + B(1,J)=B(1,J)/PER +110 CONTINUE + RETURN +120 IER=1 + RETURN + END diff --git a/Utilib/src/ALSBC.f b/Utilib/src/ALSBC.f new file mode 100644 index 0000000..b6684c6 --- /dev/null +++ b/Utilib/src/ALSBC.f @@ -0,0 +1,92 @@ +*DECK ALSBC + SUBROUTINE ALSBC (N,IS,B,IER,MAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solution of a system of linear equations using gaussian elimination +* with partial pivoting. COMPLEX*16 version. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N order of the coefficient matrix. +* IS number of right hand vectors. +* B coefficient matrix augmented with the right hand vectors. +* DIMENSION B(MAX,N+IS) +* MAX first dimention of matrix B. +* +*Parameters: output +* B solution vectors, starting at B(1,N+1). +* IER error flag. Execution failure if IER.ne.0. +* +*----------------------------------------------------------------------- +* + IMPLICIT COMPLEX*16 (A-H,O-Z) + DOUBLE PRECISION TEST + DIMENSION B(MAX,*) + IN=0 + M=N+IS + IER=0 + IF (N.EQ.1) GO TO 100 +* +* SEARCH FOR MAXIMUM PIVOT ON COLUMN JCOL. + NM1=N-1 + NP1=N+1 + DO 60 JCOL=1,NM1 + TEST=0.0D0 + DO 10 I=JCOL,N + IF (ABS(B(I,JCOL)).LE.TEST) GO TO 10 + TEST=ABS(B(I,JCOL)) + IN=I +10 CONTINUE + IF (TEST.EQ.0.0D0) GO TO 120 +* +* TRIANGULARIZATION. + PMX=B(IN,JCOL) + B(IN,JCOL)=B(JCOL,JCOL) + IP1=JCOL+1 + DO 50 J=IP1,M + PER=B(IN,J)/PMX + B(IN,J)=B(JCOL,J) + B(JCOL,J)=PER + DO 40 I=IP1,N + B(I,J)=B(I,J)-B(I,JCOL)*PER +40 CONTINUE +50 CONTINUE +60 CONTINUE + PER=B(N,N) + DO 70 J=NP1,M + B(N,J)=B(N,J)/PER +70 CONTINUE +* +* BACK SUBSTITUTION. + DO 95 IN=2,N + I=N-IN+1 + IP1=I+1 + DO 90 J=NP1,M + PER=B(I,J) + DO 80 K=IP1,N + PER=PER-B(I,K)*B(K,J) +80 CONTINUE + B(I,J)=PER +90 CONTINUE +95 CONTINUE + RETURN +* +100 PER=B(1,1) + IF (PER.EQ.(0.0D0,0.0D0)) GO TO 120 + DO 110 J=2,M + B(1,J)=B(1,J)/PER +110 CONTINUE + RETURN +120 IER=1 + RETURN + END diff --git a/Utilib/src/ALSBD.f b/Utilib/src/ALSBD.f new file mode 100644 index 0000000..b673722 --- /dev/null +++ b/Utilib/src/ALSBD.f @@ -0,0 +1,92 @@ +*DECK ALSBD + SUBROUTINE ALSBD (N,IS,B,IER,MAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solution of a system of linear equations using gaussian elimination +* with partial pivoting. Double precision version. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N order of the coefficient matrix. +* IS number of right hand vectors. +* B coefficient matrix augmented with the right hand vectors. +* DIMENSION B(MAX,N+IS) +* MAX first dimention of matrix B. +* +*Parameters: output +* B solution vectors, starting at B(1,N+1). +* IER error flag. Execution failure if IER.ne.0. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION B(MAX,*) + IN=0 + M=N+IS + IER=0 + IF (N.EQ.1) GO TO 100 +* +* SEARCH FOR MAXIMUM PIVOT ON COLUMN JCOL. + NM1=N-1 + NP1=N+1 + DO 60 JCOL=1,NM1 + TEST=0.0D0 + DO 10 I=JCOL,N + IF (ABS(B(I,JCOL)).LE.TEST) GO TO 10 + TEST=ABS(B(I,JCOL)) + IN=I +10 CONTINUE + IF (TEST.EQ.0.0D0) GO TO 120 +* +* TRIANGULARIZATION. + PMX=B(IN,JCOL) + B(IN,JCOL)=B(JCOL,JCOL) + IP1=JCOL+1 + DO 50 J=IP1,M + PER=B(IN,J)/PMX + B(IN,J)=B(JCOL,J) + B(JCOL,J)=PER + DO 40 I=IP1,N + B(I,J)=B(I,J)-B(I,JCOL)*PER +40 CONTINUE +50 CONTINUE +60 CONTINUE + PER=B(N,N) + IF (PER.EQ.0.0D0) GO TO 120 + DO 70 J=NP1,M + B(N,J)=B(N,J)/PER +70 CONTINUE +* +* BACK SUBSTITUTION. + DO 95 IN=2,N + I=N-IN+1 + IP1=I+1 + DO 90 J=NP1,M + PER=B(I,J) + DO 80 K=IP1,N + PER=PER-B(I,K)*B(K,J) +80 CONTINUE + B(I,J)=PER +90 CONTINUE +95 CONTINUE + RETURN +* +100 PER=B(1,1) + IF (PER.EQ.0.0D0) GO TO 120 + DO 110 J=2,M + B(1,J)=B(1,J)/PER +110 CONTINUE + RETURN +120 IER=1 + RETURN + END diff --git a/Utilib/src/ALST2F.f b/Utilib/src/ALST2F.f new file mode 100644 index 0000000..fe74a74 --- /dev/null +++ b/Utilib/src/ALST2F.f @@ -0,0 +1,87 @@ +*DECK ALST2F + SUBROUTINE ALST2F(MDIM,M,N,A,TAU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* to obtain the QR factorization of the matrix a using Householder +* transformations. Use LAPACK's DGEQRF routine storage. Douple precision +* routine. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Reference: +* P.A. BUSINGER, Num. Math. 7, 269-276 (1965). +* +*Parameters: input +* MDIM dimensioned column length of A. +* M number of rows of A +* N number of columns of A. N.le.M is assumed. +* A matrix A. +* +*Parameters: output +* A decomposed matrix. On exit, the elements on and above the +* diagonal of the array contain the m by n upper trapezoidal +* matrix R (R is upper triangular if m >= n); the elements +* below the diagonal, with the array TAU, represent the +* orthogonal matrix Q as a product of elementary reflectors. +* TAU scalar factors of the elementary reflectors. +* +*----------------------------------------------------------------------- +* + IMPLICIT REAL(KIND=8)(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MDIM,M,N + REAL(KIND=8) A(MDIM,N),TAU(N) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL(KIND=8), ALLOCATABLE, DIMENSION(:,:) :: W +*---- +* CHECK THE INPUT +*---- + IF(MDIM.LT.M) CALL XABORT('ALST2F: MDIM.LT.M') + IF(N.LT.1) CALL XABORT('ALST2F: N.LT.1') + IF(N.GT.M) THEN + WRITE(HSMG,'(18HALST2F: N.GT.M (N=,I3,3H M=,I3,2H).)') N,M + CALL XABORT(HSMG) + ENDIF +*---- +* PERFORM QR FACTORIZATION. +*---- + ALLOCATE(W(M,1)) + DO J=1,N + M1 = M-J+1; W(:M1,1) = A(J:M,J); X1 = W(1,1); + AX = SQRT(DOT_PRODUCT(W(:M1,1),W(:M1,1))) + A1 = ABS(X1); S = SIGN(1.0D0,W(1,1)); + SSSS = -AX*S; A1 = A1+AX; + W(1,1) = A1*S + DD2 = A1*AX + IF(DD2 == 0.0D0) CALL XABORT('ALST2F: SINGULAR REFLECTION') + W(:M1,1) = W(:M1,1)/SQRT(DD2) + A(J:M,J) = W(:M1,1) + IF(J < N) THEN + A(J:M,J+1:N) = A(J:M,J+1:N) + 1 -MATMUL(W(:M1,:),(MATMUL(TRANSPOSE(W(:M1,:)),A(J:M,J+1:N)))) + ENDIF + DIAG = A(J,J) + A(J:M,J) = A(J:M,J)/DIAG + A(J,J) = SSSS + TAU(J) = -DIAG*DIAG + ENDDO + DEALLOCATE(W) + RETURN + END diff --git a/Utilib/src/ALST2S.f b/Utilib/src/ALST2S.f new file mode 100644 index 0000000..0b543bc --- /dev/null +++ b/Utilib/src/ALST2S.f @@ -0,0 +1,77 @@ +*DECK ALST2S + SUBROUTINE ALST2S(MDIM,M,N,A,TAU,B,X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* to solve the least squares problem A*X=B when the matrix a has +* already been decomposed by ALST2F. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MDIM dimensioned column length of A. +* M number of rows of A +* N number of columns of A. N.le.M is assumed. +* A decomposed matrix. +* TAU scalar factors of the elementary reflectors. +* B right-hand side. +* +*Parameters: output +* B B has been clobbered. +* SQRT(SUM(I=N+1,M)(B(I)**2)) is the L2 norm of the residual +* in the solution of the equations. +* X solution vectors. X=B IS OK. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MDIM,M,N + DOUBLE PRECISION A(MDIM,N),TAU(N),B(M),X(N) +*---- +* CHECK THE INPUT. +*---- + IF(MDIM.LT.M) CALL XABORT('ALST2S: MDIM.LT.M') + IF(N.LT.1) CALL XABORT('ALST2S: N.LT.1') + IF(N.GT.M) CALL XABORT('ALST2S: N.GT.M') +*---- +* APPLY Q-TRANSPOSE TO B. +*---- + DO J=1,N + IF((TAU(J).EQ.0.0D0).OR.(A(J,J).EQ.0.0D0)) THEN + CALL XABORT('ALST2S: TAU(J)=0 OR A(J,J)=0') + ENDIF + S=B(J) + DO I=J+1,M + S=S+A(I,J)*B(I) + ENDDO + S=S*TAU(J) + B(J)=B(J)+S + DO I=J+1,M + B(I)=B(I)+S*A(I,J) + ENDDO + ENDDO +*---- +* BACK-SOLVE THE TRIANGULAR SYSTEM U*X=(Q-TRANSPOSE)*B. +*---- + X(N)=B(N)/A(N,N) + DO II=2,N + I=N+1-II + S=B(I) + DO J=I+1,N + S=S-A(I,J)*X(J) + ENDDO + X(I)=S/A(I,I) + ENDDO + RETURN + END diff --git a/Utilib/src/ALSVDF.f b/Utilib/src/ALSVDF.f new file mode 100644 index 0000000..351424e --- /dev/null +++ b/Utilib/src/ALSVDF.f @@ -0,0 +1,302 @@ +*DECK ALSVDF + SUBROUTINE ALSVDF(A,M,N,MP,NP,W,V) +* +*----------------------------------------------------------------------- +* +*Purpose: +* singular value decomposition. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* A matrix to decompose. +* M,N first/second mathematical dimension of matrix A +* MP,NP first/second physical dimension of matrix A +* +*Parameters: output +* A first decomposed matrix. +* W singular values. +* V second decomposed matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER M,MP,N,NP + DOUBLE PRECISION A(MP,NP),V(NP,NP),W(NP) + INTEGER I,ITS,J,JJ,K,L,NM + DOUBLE PRECISION ANORM,C,F,G,H,S,SCALE,X,Y,Z,RV0 + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RV1,RV2 +* + ALLOCATE(RV1(NP)) + NM=0 + G=0.0D0 + SCALE=0.0D0 + ANORM=0.0D0 + DO 25 I=1,N + L=I+1 + RV1(I)=SCALE*G + G=0.0D0 + S=0.0D0 + SCALE=0.0D0 + IF(I.LE.M)THEN + DO 11 K=I,M + SCALE=SCALE+ABS(A(K,I)) +11 CONTINUE + IF(SCALE.NE.0.0D0)THEN + DO 12 K=I,M + A(K,I)=A(K,I)/SCALE + S=S+A(K,I)*A(K,I) +12 CONTINUE + F=A(I,I) + G=-SIGN(SQRT(S),F) + H=F*G-S + A(I,I)=F-G + DO 15 J=L,N + S=0.0D0 + DO 13 K=I,M + S=S+A(K,I)*A(K,J) +13 CONTINUE + F=S/H + DO 14 K=I,M + A(K,J)=A(K,J)+F*A(K,I) +14 CONTINUE +15 CONTINUE + DO 16 K=I,M + A(K,I)=SCALE*A(K,I) +16 CONTINUE + ENDIF + ENDIF + W(I)=SCALE*G + G=0.0D0 + S=0.0D0 + SCALE=0.0D0 + IF((I.LE.M).AND.(I.NE.N))THEN + DO 17 K=L,N + SCALE=SCALE+ABS(A(I,K)) +17 CONTINUE + IF(SCALE.NE.0.0D0)THEN + DO 18 K=L,N + A(I,K)=A(I,K)/SCALE + S=S+A(I,K)*A(I,K) +18 CONTINUE + F=A(I,L) + G=-SIGN(SQRT(S),F) + H=F*G-S + A(I,L)=F-G + DO 19 K=L,N + RV1(K)=A(I,K)/H +19 CONTINUE + DO 23 J=L,M + S=0.0D0 + DO 21 K=L,N + S=S+A(J,K)*A(I,K) +21 CONTINUE + DO 22 K=L,N + A(J,K)=A(J,K)+S*RV1(K) +22 CONTINUE +23 CONTINUE + DO 24 K=L,N + A(I,K)=SCALE*A(I,K) +24 CONTINUE + ENDIF + ENDIF + ANORM=MAX(ANORM,(ABS(W(I))+ABS(RV1(I)))) +25 CONTINUE + DO 32 I=N,1,-1 + IF(I.LT.N)THEN + IF(G.NE.0.0D0)THEN + DO 26 J=L,N + V(J,I)=(A(I,J)/A(I,L))/G +26 CONTINUE + DO 29 J=L,N + S=0.0D0 + DO 27 K=L,N + S=S+A(I,K)*V(K,J) +27 CONTINUE + DO 28 K=L,N + V(K,J)=V(K,J)+S*V(K,I) +28 CONTINUE +29 CONTINUE + ENDIF + DO 31 J=L,N + V(I,J)=0.0D0 + V(J,I)=0.0D0 +31 CONTINUE + ENDIF + V(I,I)=1.0D0 + G=RV1(I) + L=I +32 CONTINUE + DO 39 I=MIN(M,N),1,-1 + L=I+1 + G=W(I) + DO 33 J=L,N + A(I,J)=0.0D0 +33 CONTINUE + IF(G.NE.0.0D0)THEN + G=1.0D0/G + DO 36 J=L,N + S=0.0D0 + DO 34 K=L,M + S=S+A(K,I)*A(K,J) +34 CONTINUE + F=(S/A(I,I))*G + DO 35 K=I,M + A(K,J)=A(K,J)+F*A(K,I) +35 CONTINUE +36 CONTINUE + DO 37 J=I,M + A(J,I)=A(J,I)*G +37 CONTINUE + ELSE + DO 38 J= I,M + A(J,I)=0.0D0 +38 CONTINUE + ENDIF + A(I,I)=A(I,I)+1.0D0 +39 CONTINUE + DO 49 K=N,1,-1 + DO 48 ITS=1,30 + DO 41 L=K,1,-1 + NM=L-1 + IF((ABS(RV1(L))+ANORM).EQ.ANORM) GOTO 2 + IF((ABS(W(NM))+ANORM).EQ.ANORM) GOTO 1 +41 CONTINUE +1 C=0.0D0 + S=1.0D0 + DO 43 I=L,K + F=S*RV1(I) + RV1(I)=C*RV1(I) + IF((ABS(F)+ANORM).EQ.ANORM) GOTO 2 + G=W(I) + IF(ABS(F).GT.ABS(G))THEN + W(I)=ABS(F)*SQRT(1.0D0+(ABS(G)/ABS(F))**2) + ELSE + IF(ABS(G).EQ.0.0D0)THEN + W(I)=0.0D0 + ELSE + W(I)=ABS(G)*SQRT(1.0D0+(ABS(F)/ABS(G))**2) + ENDIF + ENDIF + H=1.0D0/W(I) + C= (G*H) + S=-(F*H) + DO 42 J=1,M + Y=A(J,NM) + Z=A(J,I) + A(J,NM)=(Y*C)+(Z*S) + A(J,I)=-(Y*S)+(Z*C) +42 CONTINUE +43 CONTINUE +2 Z=W(K) + IF(L.EQ.K)THEN + IF(Z.LT.0.0D0)THEN + W(K)=-Z + DO 44 J=1,N + V(J,K)=-V(J,K) +44 CONTINUE + ENDIF + GOTO 3 + ENDIF + IF(ITS.EQ.30) CALL XABORT('ALSVDF: NO CONVERGENCE.') + X=W(L) + NM=K-1 + Y=W(NM) + G=RV1(NM) + H=RV1(K) + F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0D0*H*Y) + IF(ABS(F).GT.1.0D0)THEN + G=ABS(F)*SQRT(1.0D0+(1.0D0/ABS(F))**2) + ELSE + G=SQRT(1.0D0+(ABS(F))**2) + ENDIF + F=((X-Z)*(X+Z)+H*((Y/(F+SIGN(G,F)))-H))/X + C=1.0D0 + S=1.0D0 + DO 47 J=L,NM + I=J+1 + G=RV1(I) + Y=W(I) + H=S*G + G=C*G + IF(ABS(F).GT.ABS(H))THEN + Z=ABS(F)*SQRT(1.0D0+(ABS(H)/ABS(F))**2) + ELSE + IF(ABS(H).EQ.0.D0)THEN + Z=0.0D0 + ELSE + Z=ABS(H)*SQRT(1.0D0+(ABS(F)/ABS(H))**2) + ENDIF + ENDIF + RV1(J)=Z + C=F/Z + S=H/Z + F= (X*C)+(G*S) + G=-(X*S)+(G*C) + H=Y*S + Y=Y*C + DO 45 JJ=1,N + X=V(JJ,J) + Z=V(JJ,I) + V(JJ,J)= (X*C)+(Z*S) + V(JJ,I)=-(X*S)+(Z*C) +45 CONTINUE + IF(ABS(F).GT.ABS(H))THEN + Z=ABS(F)*SQRT(1.0D0+(ABS(H)/ABS(F))**2) + ELSE + IF(ABS(H).EQ.0.D0)THEN + Z=0.0D0 + ELSE + Z=ABS(H)*SQRT(1.0D0+(ABS(F)/ABS(H))**2) + ENDIF + ENDIF + W(J)=Z + IF(Z.NE.0.0D0)THEN + Z=1.0D0/Z + C=F*Z + S=H*Z + ENDIF + F= (C*G)+(S*Y) + X=-(S*G)+(C*Y) + DO 46 JJ=1,M + Y=A(JJ,J) + Z=A(JJ,I) + A(JJ,J)= (Y*C)+(Z*S) + A(JJ,I)=-(Y*S)+(Z*C) +46 CONTINUE +47 CONTINUE + RV1(L)=0.0D0 + RV1(K)=F + W(K)=X +48 CONTINUE +3 CONTINUE +49 CONTINUE + DEALLOCATE(RV1) +* +* Sort the data from highest to lowest singular value + ALLOCATE(RV1(M),RV2(N)) + DO I=1,NP + DO J=1,NP-I + IF(W(J).LE.W(J+1)) THEN + RV0=W(J) + RV1(:M)=A(:M,J) + RV2(:N)=V(:N,J) + W(J)=W(J+1) + A(:M,J)=A(:M,J+1) + V(:N,J)=V(:N,J+1) + W(J+1)=RV0 + A(:M,J+1)=RV1(:M) + V(:N,J+1)=RV2(:N) + ENDIF + ENDDO + ENDDO + DEALLOCATE(RV2,RV1) + RETURN + END diff --git a/Utilib/src/ALSVDS.f b/Utilib/src/ALSVDS.f new file mode 100644 index 0000000..dfe50e9 --- /dev/null +++ b/Utilib/src/ALSVDS.f @@ -0,0 +1,56 @@ +*DECK ALSVDS + SUBROUTINE ALSVDS(U,W,V,M,N,MP,NP,B,X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* linear system solution after singular value decomposition. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* U first decomposed matrix. +* W singular values. +* V second decomposed matrix. +* M,N first/second mathematical dimension of matrix A +* MP,NP first/second physical dimension of matrix A +* B RHS vector. +* +*Parameters: output +* X solution vector. +* +*----------------------------------------------------------------------- +* + INTEGER M,MP,N,NP + DOUBLE PRECISION B(MP),U(MP,NP),V(NP,NP),W(NP),X(NP),S + INTEGER I,J,JJ + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: TMP +* + ALLOCATE(TMP(NP)) + DO 12 J=1,N + S=0.0D0 + IF(W(J).NE.0.0D0)THEN + DO 11 I=1,M + S=S+U(I,J)*B(I) +11 CONTINUE + S=S/W(J) + ENDIF + TMP(J)=S +12 CONTINUE + DO 14 J=1,N + S=0.0D0 + DO 13 JJ=1,N + S=S+V(J,JJ)*TMP(JJ) +13 CONTINUE + X(J)=S +14 CONTINUE + DEALLOCATE(TMP) + RETURN + END diff --git a/Utilib/src/ALTERI.f b/Utilib/src/ALTERI.f new file mode 100644 index 0000000..8d3a246 --- /dev/null +++ b/Utilib/src/ALTERI.f @@ -0,0 +1,162 @@ +*DECK ALTERI + SUBROUTINE ALTERI(LCUBIC,N,X,VAL0,VAL1,TERP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* determination of the TERP integration components using the order 4 +* Ceschino method with cubic Hermite polynomials. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LCUBIC =.TRUE.: cubic Ceschino interpolation; =.FALSE: linear +* Lagrange interpolation. +* N number of points. +* X abscissas +* VAL0 left integration limit. +* VAL1 right integration limit. +* +*Parameters: output +* TERP integration components. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LCUBIC + INTEGER N + REAL X(N),VAL0,VAL1,TERP(N) +*---- +* LOCAL VARIABLES +*---- + REAL UU(2) + REAL, ALLOCATABLE, DIMENSION(:,:) :: WK +* + IF(N.LE.1) CALL XABORT('ALTERI: INVALID NUMBER OF POINTS.') + IF(VAL1.LE.VAL0) CALL XABORT('ALTERI: INVALID LIMITS.') + IF((VAL0.LT.X(1)).OR.(VAL1.GT.X(N))) CALL XABORT('ALTERI: UNABLE' + 1 //' TO INTEGRATE.') + IF(N.EQ.2) GO TO 110 + DO 10 I=1,N + TERP(I)=0.0 + 10 CONTINUE +*---- +* LINEAR LAGRANGE POLYNOMIALS. +*---- + IF(.NOT.LCUBIC) THEN + DO 15 I0=1,N-1 + IF((VAL0.LT.X(I0+1)).AND.(VAL1.GT.X(I0))) THEN + A=MAX(VAL0,X(I0)) + B=MIN(VAL1,X(I0+1)) + DX=X(I0+1)-X(I0) + TERP(I0)=TERP(I0)+(X(I0+1)-0.5*(A+B))*(B-A)/DX + TERP(I0+1)=TERP(I0+1)+(0.5*(A+B)-X(I0))*(B-A)/DX + ENDIF + 15 CONTINUE + RETURN + ENDIF +*---- +* CESCHINO CUBIC POLYNOMIALS. +*---- + ALLOCATE(WK(3,N)) + DO 16 I=1,N + WK(3,I)=0.0 + 16 CONTINUE + DO 30 I0=1,N-1 + IF((VAL0.LT.X(I0+1)).AND.(VAL1.GT.X(I0))) THEN + A=MAX(VAL0,X(I0)) + B=MIN(VAL1,X(I0+1)) + CC=0.5*(B-A) + DX=X(I0+1)-X(I0) + U1=(A-0.5*(X(I0)+X(I0+1)))/DX + U2=(B-0.5*(X(I0)+X(I0+1)))/DX + UU(1)=0.5*(-(U2-U1)*0.577350269189626+U1+U2) + UU(2)=0.5*((U2-U1)*0.577350269189626+U1+U2) + DO 20 JS=1,2 + H1=(3.0*(0.5-UU(JS))**2-2.0*(0.5-UU(JS))**3)*CC + H2=((0.5-UU(JS))**2-(0.5-UU(JS))**3)*CC + H3=(3.0*(0.5+UU(JS))**2-2.0*(0.5+UU(JS))**3)*CC + H4=(-(0.5+UU(JS))**2+(0.5+UU(JS))**3)*CC + TERP(I0)=TERP(I0)+H1 + TERP(I0+1)=TERP(I0+1)+H3 + WK(3,I0)=WK(3,I0)+H2*DX + WK(3,I0+1)=WK(3,I0+1)+H4*DX + 20 CONTINUE + ENDIF + 30 CONTINUE +*---- +* COMPUTE THE COEFFICIENT MATRIX. +*---- + HP=1.0/(X(2)-X(1)) + WK(1,1)=HP + WK(2,1)=HP + DO 40 I=2,N-1 + HM=HP + HP=1.0/(X(I+1)-X(I)) + WK(1,I)=2.0*(HM+HP) + WK(2,I)=HP + 40 CONTINUE + WK(1,N)=HP + WK(2,N)=HP +*---- +* FORWARD ELIMINATION. +*---- + PMX=WK(1,1) + WK(3,1)=WK(3,1)/PMX + DO 50 I=2,N + GAR=WK(2,I-1) + WK(2,I-1)=WK(2,I-1)/PMX + PMX=WK(1,I)-GAR*WK(2,I-1) + WK(3,I)=(WK(3,I)-GAR*WK(3,I-1))/PMX + 50 CONTINUE +*---- +* BACK SUBSTITUTION. +*---- + DO 60 I=N-1,1,-1 + WK(3,I)=WK(3,I)-WK(2,I)*WK(3,I+1) + 60 CONTINUE +*---- +* COMPUTE THE INTERPOLATION FACTORS. +*---- + TEST=1.0 + DO 100 J=1,N + IMIN=MAX(2,J-1) + IMAX=MIN(N-1,J+1) + DO 70 I=1,N + WK(1,I)=0.0 + 70 CONTINUE + WK(1,J)=1.0 + HP=1.0/(X(2)-X(1)) + YLAST=WK(1,IMIN-1) + WK(1,IMIN-1)=2.0*HP*HP*(WK(1,IMIN)-WK(1,IMIN-1)) + DO 80 I=IMIN,IMAX + HM=HP + HP=1.0/(X(I+1)-X(I)) + PMX=3.0*(HM*HM*(WK(1,I)-YLAST)+HP*HP*(WK(1,I+1)-WK(1,I))) + YLAST=WK(1,I) + WK(1,I)=PMX + 80 CONTINUE + WK(1,IMAX+1)=2.0*HP*HP*(WK(1,IMAX+1)-YLAST) + DO 90 I=IMIN-1,IMAX+1 + TERP(J)=TERP(J)+WK(1,I)*WK(3,I) + 90 CONTINUE + IF(ABS(TERP(J)).LE.1.0E-7) TERP(J)=0.0 + TEST=TEST-TERP(J)/(VAL1-VAL0) + 100 CONTINUE + IF(ABS(TEST).GT.1.0E-5) CALL XABORT('ALTERI: WRONG TERP FACTORS.') + DEALLOCATE(WK) + RETURN +* + 110 TERP(1)=(X(2)-0.5*(VAL0+VAL1))*(VAL1-VAL0)/(X(2)-X(1)) + TERP(2)=(0.5*(VAL0+VAL1)-X(1))*(VAL1-VAL0)/(X(2)-X(1)) + RETURN + END diff --git a/Utilib/src/ALTERP.f b/Utilib/src/ALTERP.f new file mode 100644 index 0000000..379a3fd --- /dev/null +++ b/Utilib/src/ALTERP.f @@ -0,0 +1,172 @@ +*DECK ALTERP + SUBROUTINE ALTERP(LCUBIC,N,X,VAL,LDERIV,TERP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* determination of the TERP interpolation/derivation components using +* the order 4 Ceschino method with cubic Hermite polynomials. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LCUBIC =.TRUE.: cubic Ceschino interpolation; =.FALSE: linear +* Lagrange interpolation. +* N number of points. +* X abscissas +* VAL abscissa of the interpolated point. +* LDERIV set to .true. to compute the first derivative with respect +* to X. Set to .false. to interpolate. +* +*Parameters: output +* TERP interpolation/derivation components. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N + LOGICAL LCUBIC,LDERIV + REAL X(N),VAL,TERP(N) +*--- +* LOCAL VARIABLES +*--- + CHARACTER HSMG*131 + REAL, ALLOCATABLE, DIMENSION(:,:) :: WK +* + I0=0 + IF(N.LE.1) CALL XABORT('ALTERP: INVALID NUMBER OF POINTS.') + IF(N.EQ.2) GO TO 110 + DO 10 I=1,N + TERP(I)=0.0 + 10 CONTINUE +*---- +* INTERVAL IDENTIFICATION. +*---- + DO 20 I=1,N-1 + IF((VAL.GE.X(I)).AND.(VAL.LE.X(I+1))) THEN + I0=I + GO TO 30 + ENDIF + 20 CONTINUE + WRITE(HSMG,'(35HALTERP: UNABLE TO INTERPOLATE (VAL=,1P,E11.4, + 1 8H LIMITS=,E11.4,2H, ,E11.4,2H).)') VAL,X(1),X(N) + CALL XABORT(HSMG) + 30 DX=X(I0+1)-X(I0) +*---- +* LINEAR LAGRANGE POLYNOMIAL. +*---- + IF(.NOT.LCUBIC) THEN + IF(LDERIV) THEN + TERP(I0)=-1.0/DX + TERP(I0+1)=1.0/DX + ELSE + TERP(I0)=(X(I0+1)-VAL)/DX + TERP(I0+1)=1.0-TERP(I0) + ENDIF + RETURN + ENDIF +*---- +* CESCHINO CUBIC POLYNOMIAL. +*---- + ALLOCATE(WK(3,N)) + DO 35 I=1,N + WK(3,I)=0.0 + 35 CONTINUE + U=(VAL-0.5*(X(I0)+X(I0+1)))/DX + IF(LDERIV) THEN + H1=(-6.0*(0.5-U)+6.0*(0.5-U)**2)/DX + H2=(-2.0*(0.5-U)+3.0*(0.5-U)**2)/DX + H3=(6.0*(0.5+U)-6.0*(0.5+U)**2)/DX + H4=(-2.0*(0.5+U)+3.0*(0.5+U)**2)/DX + TEST=0.0 + ELSE + H1=3.0*(0.5-U)**2-2.0*(0.5-U)**3 + H2=(0.5-U)**2-(0.5-U)**3 + H3=3.0*(0.5+U)**2-2.0*(0.5+U)**3 + H4=-(0.5+U)**2+(0.5+U)**3 + TEST=1.0 + ENDIF + TERP(I0)=H1 + TERP(I0+1)=H3 + WK(3,I0)=H2*DX + WK(3,I0+1)=H4*DX +*---- +* COMPUTE THE COEFFICIENT MATRIX. +*---- + HP=1.0/(X(2)-X(1)) + WK(1,1)=HP + WK(2,1)=HP + DO 40 I=2,N-1 + HM=HP + HP=1.0/(X(I+1)-X(I)) + WK(1,I)=2.0*(HM+HP) + WK(2,I)=HP + 40 CONTINUE + WK(1,N)=HP + WK(2,N)=HP +*---- +* FORWARD ELIMINATION. +*---- + PMX=WK(1,1) + WK(3,1)=WK(3,1)/PMX + DO 50 I=2,N + GAR=WK(2,I-1) + WK(2,I-1)=WK(2,I-1)/PMX + PMX=WK(1,I)-GAR*WK(2,I-1) + WK(3,I)=(WK(3,I)-GAR*WK(3,I-1))/PMX + 50 CONTINUE +*---- +* BACK SUBSTITUTION. +*---- + DO 60 I=N-1,1,-1 + WK(3,I)=WK(3,I)-WK(2,I)*WK(3,I+1) + 60 CONTINUE +*---- +* COMPUTE THE INTERPOLATION FACTORS. +*---- + DO 100 J=1,N + IMIN=MAX(2,J-1) + IMAX=MIN(N-1,J+1) + DO 70 I=1,N + WK(1,I)=0.0 + 70 CONTINUE + WK(1,J)=1.0 + HP=1.0/(X(IMIN)-X(IMIN-1)) + YLAST=WK(1,IMIN-1) + WK(1,IMIN-1)=2.0*HP*HP*(WK(1,IMIN)-WK(1,IMIN-1)) + DO 80 I=IMIN,IMAX + HM=HP + HP=1.0/(X(I+1)-X(I)) + PMX=3.0*(HM*HM*(WK(1,I)-YLAST)+HP*HP*(WK(1,I+1)-WK(1,I))) + YLAST=WK(1,I) + WK(1,I)=PMX + 80 CONTINUE + WK(1,IMAX+1)=2.0*HP*HP*(WK(1,IMAX+1)-YLAST) + DO 90 I=IMIN-1,IMAX+1 + TERP(J)=TERP(J)+WK(1,I)*WK(3,I) + 90 CONTINUE + IF(ABS(TERP(J)).LE.1.0E-7) TERP(J)=0.0 + TEST=TEST-TERP(J) + 100 CONTINUE + IF(ABS(TEST).GT.1.0E-5) CALL XABORT('ALTERP: WRONG TERP FACTORS.') + DEALLOCATE(WK) + RETURN +* + 110 IF(LDERIV) THEN + TERP(1)=-1.0/(X(2)-X(1)) + TERP(2)=1.0/(X(2)-X(1)) + ELSE + TERP(1)=(X(2)-VAL)/(X(2)-X(1)) + TERP(2)=1.0-TERP(1) + ENDIF + RETURN + END diff --git a/Utilib/src/ALVDLF.f b/Utilib/src/ALVDLF.f new file mode 100644 index 0000000..034b70c --- /dev/null +++ b/Utilib/src/ALVDLF.f @@ -0,0 +1,94 @@ +*DECK ALVDLF + SUBROUTINE ALVDLF (ASS,MU1,ISEG,LON,NBL,LBL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* in-place L-D-L(T) factorization of a symmetric positive definite +* matrix in compressed diagonal storage mode. Supervectorial version +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ASS coefficient matrix in compressed diagonal storage mode. +* DIMENSION ASS(ISEG,MU1(L4)) +* MU1 position of each diagonal element in vector ASS. +* DIMENSION MU1(L4) where L4=SUM(LBL(I)) +* ISEG number of elements in a vector register. +* LON number of groups of linear systems. +* NBL number of linear systems in each group. DIMENSION NBL(LON) +* LBL number of unknowns in each group. DIMENSION LBL(LON) +* +*Parameters: output +* ASS LDL(T) factors of the coefficient matrix in compressed +* diagonal storage mode. +* +*----------------------------------------------------------------------- +* + INTEGER ISEG,LON,MU1(*),NBL(LON),LBL(LON) + REAL ASS(ISEG,*) + REAL, DIMENSION(:), ALLOCATABLE :: T +* + ALLOCATE(T(ISEG)) + LBL0=0 + DO ILON=1,LON + L4=LBL(ILON) + NBANC=NBL(ILON) + DO IB=1,NBANC + ASS(IB,MU1(LBL0+1))=1.0/ASS(IB,MU1(LBL0+1)) + ENDDO + IF (L4.NE.1) THEN + DO K=LBL0+2,LBL0+L4 + K1=MU1(K)-K + KM=MU1(K-1)+1-K1 + IF(KM+1-K .LE. 0) THEN + IF(KM+1-K .LT. 0) THEN + DO I=KM+1,K-1 + DO IB=1,NBANC + T(IB)=ASS(IB,K1+I) + ASS(IB,K1+I)=0.0 + ENDDO + I1=MU1(I)-I + IM=MU1(I-1)+1-I1 + IMIN=MAX0(IM,KM) + DO J=IMIN,I + DO IB=1,NBANC + T(IB)=T(IB)-ASS(IB,K1+J)*ASS(IB,I1+J) + ENDDO + ENDDO + DO IB=1,NBANC + ASS(IB,K1+I)=T(IB) + ENDDO + ENDDO + ENDIF + DO IB=1,NBANC + T(IB)=0.0 + ENDDO + DO I=KM,K-1 + DO IB=1,NBANC + GAR=ASS(IB,K1+I) + ASS(IB,K1+I)=GAR*ASS(IB,MU1(I)) + T(IB)=T(IB)+GAR*ASS(IB,K1+I) + ENDDO + ENDDO + DO IB=1,NBANC + ASS(IB,MU1(K))=ASS(IB,MU1(K))-T(IB) + ENDDO + ENDIF + DO IB=1,NBANC + ASS(IB,MU1(K))=1.0/ASS(IB,MU1(K)) + ENDDO + ENDDO + ENDIF + LBL0=LBL0+L4 + ENDDO + DEALLOCATE(T) + RETURN + END diff --git a/Utilib/src/ALVDLM.f b/Utilib/src/ALVDLM.f new file mode 100644 index 0000000..c619a01 --- /dev/null +++ b/Utilib/src/ALVDLM.f @@ -0,0 +1,125 @@ +*DECK ALVDLM + SUBROUTINE ALVDLM (LTSW,ASS,VEC,Z,MU1,ITY,ISEG,LON,NBL,LBL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* multiplication of a symmetric matrix in compressed diagonal storage +* mode by a vector. Supervectorial version. +* +*Copyright: +* Copyright (C) 1992 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LTSW maximum bandwidth. =2 for tridiagonal systems. +* ASS LDL(T) factors of the coefficient matrix in compressed +* diagonal storage mode. DIMENSION ASS(ISEG,MU1(L4)) +* VEC vector to multiply. +* Z vector that will be added to the result if ITY=2. +* DIMENSION VEC(ISEG,L4),Z(ISEG,L4) WHERE L4=SUM(LBL(I)) +* MU1 position of each diagonal element in vector ASS. +* DIMENSION MU1(L4) +* ITY type of multiplication (ITY=1: Z=ASS*VEC; +* ITY=2: Z=Z+(ASS-DIAG(ASS))*VEC). +* ISEG number of elements in a vector register. +* LON number of groups of linear systems. +* NBL number of linear systems in each group. DIMENSION NBL(LON) +* LBL number of unknowns in each group. DIMENSION LBL(LON) +* +*Parameters: output +* Z solution of the multiplication. DIMENSION Z(ISEG,L4) +* +*----------------------------------------------------------------------- +* + DIMENSION ASS(ISEG,*),VEC(ISEG,*),Z(ISEG,*),MU1(*),NBL(*),LBL(*) + LBL0=0 + IMAX=0 + DO 300 ILON=1,LON + L4=LBL(ILON) + NBANC=NBL(ILON) + IF((LTSW.GT.2).AND.(ITY.EQ.1)) THEN +* CALCULATION OF Z=ASS*VEC. +CDIR$ SHORTLOOP + DO 30 IB=1,NBANC + Z(IB,LBL0+1)=ASS(IB,MU1(LBL0+1))*VEC(IB,LBL0+1) + 30 CONTINUE + I1=MU1(LBL0+1)+1 + DO 90 K=LBL0+2,LBL0+L4 + I2=MU1(K) + KEY1=I2-K +CDIR$ SHORTLOOP + DO 40 IB=1,NBANC + Z(IB,K)=0.0 + 40 CONTINUE + DO 60 L=K+I1-I2,K-1 + KEYL=KEY1+L +CDIR$ SHORTLOOP + DO 50 IB=1,NBANC + Z(IB,K)=Z(IB,K)+ASS(IB,KEYL)*VEC(IB,L) + Z(IB,L)=Z(IB,L)+ASS(IB,KEYL)*VEC(IB,K) + 50 CONTINUE + 60 CONTINUE +CDIR$ SHORTLOOP + DO 80 IB=1,NBANC + Z(IB,K)=Z(IB,K)+ASS(IB,KEY1+K)*VEC(IB,K) + 80 CONTINUE + I1=I2+1 + 90 CONTINUE + ELSE IF((LTSW.GT.2).AND.(ITY.EQ.2)) THEN +* CALCULATION OF Z=Z+(ASS-DIAG(ASS))*VEC. + I1=MU1(LBL0+1)+1 + DO 150 K=LBL0+2,LBL0+L4 + I2=MU1(K) + KEY1=I2-K + IF(I1.EQ.I2) GO TO 150 + DO 130 L=K+I1-I2,K-1 + KEYL=KEY1+L +CDIR$ SHORTLOOP + DO 120 IB=1,NBANC + Z(IB,K)=Z(IB,K)+ASS(IB,KEYL)*VEC(IB,L) + Z(IB,L)=Z(IB,L)+ASS(IB,KEYL)*VEC(IB,K) + 120 CONTINUE + 130 CONTINUE + I1=I2+1 + 150 CONTINUE + ELSE IF((LTSW.EQ.2).AND.(ITY.EQ.1)) THEN +* CALCULATION OF Z=ASS*VEC FOR A 3-DIAGONAL SYSTEM. +CDIR$ SHORTLOOP + DO 180 IB=1,NBANC + Z(IB,LBL0+1)=ASS(IB,IMAX+1)*VEC(IB,LBL0+1) + 180 CONTINUE + I1=2 + DO 230 K=LBL0+2,LBL0+L4 + KEYL=IMAX+I1 +CDIR$ SHORTLOOP + DO 210 IB=1,NBANC + Z(IB,K)=ASS(IB,KEYL)*VEC(IB,K-1)+ASS(IB,KEYL+1)*VEC(IB,K) + Z(IB,K-1)=Z(IB,K-1)+ASS(IB,KEYL)*VEC(IB,K) + 210 CONTINUE + I1=I1+2 + 230 CONTINUE + IMAX=IMAX+I1-1 + ELSE IF((LTSW.EQ.2).AND.(ITY.EQ.2)) THEN +* CALCULATION OF Z=Z+(ASS-DIAG(ASS))*VEC FOR A 3-DIAGONAL SYSTEM. + I1=2 + DO 280 K=LBL0+2,LBL0+L4 + KEYL=IMAX+I1 +CDIR$ SHORTLOOP + DO 260 IB=1,NBANC + Z(IB,K)=Z(IB,K)+ASS(IB,KEYL)*VEC(IB,K-1) + Z(IB,K-1)=Z(IB,K-1)+ASS(IB,KEYL)*VEC(IB,K) + 260 CONTINUE + I1=I1+2 + 280 CONTINUE + IMAX=IMAX+I1-1 + ENDIF + LBL0=LBL0+L4 + 300 CONTINUE + RETURN + END diff --git a/Utilib/src/ALVDLS.f b/Utilib/src/ALVDLS.f new file mode 100644 index 0000000..3c35a72 --- /dev/null +++ b/Utilib/src/ALVDLS.f @@ -0,0 +1,143 @@ +*DECK ALVDLS + SUBROUTINE ALVDLS (LTSW,MU1,ASS,F,ISEG,LON,NBL,LBL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solution of a symmetric linear system where the coefficient matrix +* have been previously factorized as LDL(T). Supervectorial version. +* +*Copyright: +* Copyright (C) 1992 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LTSW maximum bandwidth. =2 for tridiagonal systems. +* MU1 position of each diagonal element in vector ass. +* DIMENSION MU1(L4) where L4=SUM(LBL(I)) +* ASS LDL(T) factors of the coefficient matrix in compressed +* diagonal storage mode. DIMENSION ASS(ISEG,MU1(L4)) +* F right-hand side of the linear system. DIMENSION F(ISEG,L4) +* ISEG number of elements in a vector register. +* LON number of groups of linear systems. +* NBL number of linear systems in each group. DIMENSION NBL(LON) +* LBL number of unknowns in each group. DIMENSION LBL(LON) +* +*Parameters: output +* F solution of the linear system. DIMENSION F(ISEG,L4) +* +*----------------------------------------------------------------------- +* + INTEGER ISEG,LON,MU1(*),NBL(LON),LBL(LON) + REAL ASS(ISEG,*),F(ISEG,*) + REAL, DIMENSION(:), ALLOCATABLE :: T +* + ALLOCATE(T(ISEG)) + LBL0=0 + IMAX=0 + DO 200 ILON=1,LON + L4=LBL(ILON) + NBANC=NBL(ILON) + IF(L4.EQ.1) THEN + IMAX=IMAX+1 +CDIR$ SHORTLOOP + DO 10 IB=1,NBANC + F(IB,LBL0+1)=F(IB,LBL0+1)*ASS(IB,IMAX) + 10 CONTINUE + ELSE IF(LTSW.GT.2) THEN + IMAX=MU1(LBL0+L4) + K1=MU1(LBL0+1)+1 + DO 55 I=LBL0+2,LBL0+L4 + K2=MU1(I) + KJ=I-K2+K1 +CDIR$ SHORTLOOP + DO 20 IB=1,NBANC + T(IB)=-F(IB,I) + 20 CONTINUE + DO 40 K=K1,K2-1 +CDIR$ SHORTLOOP + DO 30 IB=1,NBANC + T(IB)=T(IB)+F(IB,KJ)*ASS(IB,K) + 30 CONTINUE + KJ=KJ+1 + 40 CONTINUE + K1=K2+1 +CDIR$ SHORTLOOP + DO 50 IB=1,NBANC + F(IB,I)=-T(IB) + 50 CONTINUE + 55 CONTINUE +* + DO 65 I=LBL0+1,LBL0+L4 + K1=MU1(I) +CDIR$ SHORTLOOP + DO 60 IB=1,NBANC + F(IB,I)=F(IB,I)*ASS(IB,K1) + 60 CONTINUE + 65 CONTINUE +* + K2=IMAX + DO 100 I=LBL0+L4,LBL0+2,-1 +CDIR$ SHORTLOOP + DO 70 IB=1,NBANC + T(IB)=-F(IB,I) + 70 CONTINUE + K1=MU1(I-1)+1 + KJ=I-K2+K1 + DO 90 K=K1,K2-1 +CDIR$ SHORTLOOP + DO 80 IB=1,NBANC + F(IB,KJ)=F(IB,KJ)+ASS(IB,K)*T(IB) + 80 CONTINUE + KJ=KJ+1 + 90 CONTINUE + K2=K1-1 + 100 CONTINUE + ELSE IF(LTSW.EQ.2) THEN + K1=IMAX+2 + DO 130 I=LBL0+2,LBL0+L4 + KJ=I-1 +CDIR$ SHORTLOOP + DO 110 IB=1,NBANC + T(IB)=-F(IB,I)+F(IB,KJ)*ASS(IB,K1) + 110 CONTINUE +CDIR$ SHORTLOOP + DO 120 IB=1,NBANC + F(IB,I)=-T(IB) + 120 CONTINUE + K1=K1+2 + 130 CONTINUE +* + DO 145 I=LBL0+1,LBL0+L4 + K1=IMAX+2*(I-LBL0)-1 +CDIR$ SHORTLOOP + DO 140 IB=1,NBANC + F(IB,I)=F(IB,I)*ASS(IB,K1) + 140 CONTINUE + 145 CONTINUE +* + K1=IMAX+2*L4-2 + DO 170 I=LBL0+L4,LBL0+2,-1 + KJ=I-1 +CDIR$ SHORTLOOP + DO 150 IB=1,NBANC + T(IB)=-F(IB,I) + 150 CONTINUE +CDIR$ SHORTLOOP + DO 160 IB=1,NBANC + F(IB,KJ)=F(IB,KJ)+ASS(IB,K1)*T(IB) + 160 CONTINUE + K1=K1-2 + 170 CONTINUE + IMAX=IMAX+2*L4-1 + ENDIF + LBL0=LBL0+L4 + 200 CONTINUE + DEALLOCATE(T) + RETURN + END diff --git a/Utilib/src/DDOT.f b/Utilib/src/DDOT.f new file mode 100644 index 0000000..7d6de16 --- /dev/null +++ b/Utilib/src/DDOT.f @@ -0,0 +1,76 @@ +*DECK DDOT + DOUBLE PRECISION FUNCTION DDOT(N,SX,INCX,SY,INCY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* forms the dot product of two vectors. Uses unrolled loops for +* increments equal to one. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): Jack Dongarra, linpack, 3/11/78. +* +*Parameters: input +* N number of components in the vectors. +* SX first vector. +* INCX increment in first vector. +* SY second vector. +* INCY increment in second vector. +* +*Parameters: output +* DDOT dot product. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,INCX,INCY + DOUBLE PRECISION SX(N*INCX),SY(N*INCY) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,IX,IY,M,MP1 + DOUBLE PRECISION DTEMP +* + DTEMP = 0.0D0 + DDOT = 0.0D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +*---- +* CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL TO 1. +*---- + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DTEMP + SX(IX)*SY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + DDOT = DTEMP + RETURN +*---- +* CODE FOR BOTH INCREMENTS EQUAL TO 1. CLEAN-UP LOOP. +*---- + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + SX(I)*SY(I) + 30 CONTINUE + IF( N .LT. 5 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DTEMP = DTEMP + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) + + * SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4) + 50 CONTINUE + 60 DDOT = DTEMP + RETURN + END diff --git a/Utilib/src/FREESTEAM.f90 b/Utilib/src/FREESTEAM.f90 new file mode 100644 index 0000000..94dfc73 --- /dev/null +++ b/Utilib/src/FREESTEAM.f90 @@ -0,0 +1,90 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for freesteam (light water). +! +!Copyright: +! Copyright (C) 2012 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +subroutine THMSAP(p, t) +! return the saturation pressure (Pa) as a function of the temperature (K) + use, intrinsic :: iso_c_binding + real :: p, t + real(c_double) :: td + interface + real(c_double) function region4_psat_T (td) bind(c, name='freesteam_region4_psat_T') + use, intrinsic :: iso_c_binding + real(c_double), value :: td + end function region4_psat_T + end interface + td=t + p = real(region4_psat_T (td)) +end subroutine THMSAP +! +subroutine THMSAT(p, t) + ! return the saturation temperature (K) as a function of the pressure (Pa) + use, intrinsic :: iso_c_binding + real :: p, t + real(c_double) :: pd + interface + real(c_double) function region4_Tsat_p (pd) bind(c, name='freesteam_region4_Tsat_p') + use, intrinsic :: iso_c_binding + real(c_double), value :: pd + end function region4_tsat_p + end interface + pd=p + t = real(region4_tsat_p (pd)) +end subroutine THMSAT +! +subroutine THMPT(p, t, rho, h, zk, zmu, cp) + ! return the remaining thermohydraulics parameters as a function of the pressure (Pa) + ! and temperature (K) + use, intrinsic :: iso_c_binding + real :: p, t, rho, h, zk, zmu, cp + real(c_double) :: pd, td, rhod, hd, zkd, zmud, cpd + interface + subroutine free_pT (pd, td, rhod, hd, zkd, zmud, cpd) bind(c, name='free_pT') + use, intrinsic :: iso_c_binding + real(c_double) :: pd, td, rhod, hd, zkd, zmud, cpd + end subroutine free_pT + end interface + pd=p + td=t + call free_pT(pd, td, rhod, hd, zkd, zmud, cpd) + rho=real(rhod) + h=real(hd) + zk=real(zkd) + zmu=real(zmud) + cp=real(cpd) +end subroutine THMPT +! +subroutine THMTX(t, x, rho, h, zk, zmu, cp) + ! return the remaining thermohydraulics parameters as a function of the temperature (K) + ! and quality + use, intrinsic :: iso_c_binding + real :: t, x, rho, h, zmu + real(c_double) :: td, xd, rhod, hd, zkd, zmud, cpd + interface + subroutine free_Tx (td, xd, rhod, hd, zkd, zmud, cpd) bind(c, name='free_Tx') + use, intrinsic :: iso_c_binding + real(c_double) :: td, xd, rhod, hd, zkd, zmud, cpd + end subroutine free_Tx + end interface + td=t + xd=x + call free_Tx(td, xd, rhod, hd, zkd, zmud, cpd) + rho=real(rhod) + h=real(hd) + zk=real(zkd) + zmu=real(zmud) + cp=real(cpd) +end subroutine THMTX diff --git a/Utilib/src/GUCTOI.f b/Utilib/src/GUCTOI.f new file mode 100644 index 0000000..eeaf738 --- /dev/null +++ b/Utilib/src/GUCTOI.f @@ -0,0 +1,94 @@ +*DECK GUCTOI + SUBROUTINE GUCTOI(CARVAR,INTVAR,NC4 ,NELEM ) +C +C------------------------------ GUCTOI ------------------------------ +C +C PROGRAMME STATISTICS: +C NAME : GUCTOI +C ENTRY : GUCTOI +C USE : GANLIB UTILITY ROUTINE +C TRANSFERS CHARACTER VARIABLE IN INTEGER VARIABLE +C MODIFIED : 98/11/23 G. MARLEAU +C CREATION DATE +C +C ROUTINE PARAMETERS: +C INPUT +C CARVAR : CHARACTER VARIABLE C(NELEM)*(*) +C NC4 : NUMBER OF CHARACTER*4 BLOCKS IN +C CARVAR TO TRANSFER IN INTVAR I +C NBELEM : NUMBER OF ELEMENTS TO TRANSFER FROM +C CARVAR +C INPUT/OUTPUT +C INTVAR : INTEGER VARIABLE I(NC4,NELEM) +C +C------------------------------ GUCTOI ------------------------------ +C + IMPLICIT NONE + INTEGER NC4,NELEM,INTVAR(NC4,NELEM) + CHARACTER CARVAR(NELEM)*(*) +C---- +C LOCAL PARAMETERS +C---- + INTEGER LENCAR,NBC4,NRESTE,IELEM,IC4,IDC,IFC + CHARACTER FMT*8,BLANK*4,TEXT4*4 + SAVE BLANK + DATA BLANK /' '/ +C---- +C FIND LENGTH OF CHARACTER VARIABLE +C---- + LENCAR=LEN(CARVAR(1)) + NBC4 =LENCAR/4 + IF(NBC4 .GE. NC4) THEN +C---- +C CHARACTER VARIABLE LONGUER OR EQUAL TO SPACE ALLOWED IN +C INTEGER VARIABLE +C TRANSFER ONLY 4*NC4 ELEMENTS TO INTEGER VARIABLE +C--- + WRITE(FMT,1000) NC4 + DO 100 IELEM=1,NELEM + READ(CARVAR(IELEM),FMT) (INTVAR(IC4,IELEM),IC4=1,NC4) + 100 CONTINUE + ELSE +C---- +C CHARACTER VARIABLE SHORTER THAN SPACE ALLOWED IN +C INTEGER VARIABLE +C TRANSFER ALL CHARACTER VARIABLE IN INTCAR AND +C FILL REMAINING SPACE WITH BLANKS +C--- + WRITE(FMT,1000) NBC4 + NRESTE=MOD(LENCAR,4) + IF(NRESTE .EQ. 0 ) THEN +C---- +C LENGHT OF CHARACTER VARIABLE IS A FACTOR OF 4 +C---- + DO 110 IELEM=1,NELEM + READ(CARVAR(IELEM),FMT) (INTVAR(IC4,IELEM),IC4=1,NBC4) + DO 111 IC4=NBC4+1,NC4 + READ(BLANK,'(A4)') INTVAR(IC4,IELEM) + 111 CONTINUE + 110 CONTINUE + ELSE +C---- +C LENGHT OF CHARACTER VARIABLE IS NOT A FACTOR OF 4 +C---- + IDC=4*NBC4+1 + IFC=4*NBC4+NRESTE + DO 120 IELEM=1,NELEM + READ(CARVAR(IELEM),FMT) (INTVAR(IC4,IELEM),IC4=1,NBC4) + TEXT4=CARVAR(IELEM)(IDC:IFC)//BLANK(NRESTE+1:4) + READ(TEXT4,'(A4)') INTVAR(NBC4+1,IELEM) + DO 121 IC4=NBC4+2,NC4 + READ(BLANK,'(A4)') INTVAR(IC4,IELEM) + 121 CONTINUE + 120 CONTINUE + ENDIF + ENDIF +C---- +C RETURN +C---- + RETURN +C---- +C FORMAT +C---- + 1000 FORMAT('(',I4,'A4)') + END diff --git a/Utilib/src/GUITOC.f b/Utilib/src/GUITOC.f new file mode 100644 index 0000000..1e11563 --- /dev/null +++ b/Utilib/src/GUITOC.f @@ -0,0 +1,90 @@ +*DECK GUITOC + SUBROUTINE GUITOC(INTVAR,CARVAR,NC4 ,NELEM ) +C +C------------------------------ GUITOC ------------------------------ +C +C PROGRAMME STATISTICS: +C NAME : GUITOC +C ENTRY : GUITOC +C USE : GANLIB UTILITY PROGRAM +C TRANSFERS INTEGER VARIABLE TO CHARACTER VARIABLE +C MODIFIED : 98/11/23 G. MARLEAU +C CREATION DATE +C +C ROUTINE PARAMETERS: +C INPUT +C INTVAR : INTEGER VARIABLE I(NC4,NELEM) +C NC4 : NUMBER OF CHARACTER*4 BLOCKS IN +C CARVAR TO TRANSFER IN INTVAR I +C NBELEM : NUMBER OF ELEMENTS TO TRANSFER FROM +C CARVAR +C INPUT/OUTPUT +C CARVAR : CHARACTER VARIABLE C(NELEM)*(*) +C +C------------------------------ GUITOC ------------------------------ +C + IMPLICIT NONE + INTEGER NC4,NELEM,INTVAR(NC4,NELEM) + CHARACTER CARVAR(NELEM)*(*) +C---- +C LOCAL PARAMETERS +C---- + INTEGER LENCAR,NBC4,NRESTE,IELEM,IC4,IDC,IFC + CHARACTER FMT*8,BLANK*1 + SAVE BLANK + DATA BLANK /' '/ +C---- +C FIND LENGTH OF CHARACTER VARIABLE +C---- + LENCAR=LEN(CARVAR(1)) + NBC4 =LENCAR/4 + IF(NBC4 .GE. NC4) THEN +C---- +C CHARACTER VARIABLE LARGER OF EQUAL TO SPACE IN +C INTEGER VARIABLE +C TRANSFER FROM INTEGER VARIABLE ONLY 4*NC4 ELEMENTS +C--- + WRITE(FMT,1000) NC4 + DO 100 IELEM=1,NELEM + WRITE(CARVAR(IELEM),FMT) (INTVAR(IC4,IELEM),IC4=1,NC4) + DO 101 IC4=4*NC4+1,LENCAR + WRITE(CARVAR(IELEM)(IC4:IC4),'(A1)') BLANK + 101 CONTINUE + 100 CONTINUE + ELSE +C---- +C CHARACTER VARIABLE SHORTER THAN SPACE IN +C INTEGER VARIABLE +C TRANSFER FROM INTEGER VARIABLE ONLY 4*NBC4 ELEMENTS +C AND PART OF NBC4+1 ELEMENT AS DESCRIBED BY NRESTE +C--- + WRITE(FMT,1000) NBC4 +C---- +C LENGHT OF CHARACTER VARIABLE IS A FACTOR OF 4 +C---- + DO 110 IELEM=1,NELEM + READ(CARVAR(IELEM),FMT) (INTVAR(IC4,IELEM),IC4=1,NBC4) + 110 CONTINUE + NRESTE=MOD(LENCAR,4) + IF(NRESTE .NE. 0 ) THEN +C---- +C LENGHT OF CHARACTER VARIABLE IS NOT A FACTOR OF 4 +C---- + WRITE(FMT,1001) NRESTE + IDC=4*NBC4+1 + IFC=4*NBC4+NRESTE + DO 120 IELEM=1,NELEM + WRITE(CARVAR(IELEM)(IDC:IFC),FMT) INTVAR(NBC4+1,IELEM) + 120 CONTINUE + ENDIF + ENDIF +C---- +C RETURN +C---- + RETURN +C---- +C FORMAT +C---- + 1000 FORMAT('(',I4,'A4)') + 1001 FORMAT('(A',I1,') ') + END diff --git a/Utilib/src/HEAVYSTEAM.f90 b/Utilib/src/HEAVYSTEAM.f90 new file mode 100644 index 0000000..62c97d5 --- /dev/null +++ b/Utilib/src/HEAVYSTEAM.f90 @@ -0,0 +1,390 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Heavy water properties +! +!Copyright: +! Copyright (C) 2018 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modIFy it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): G. Marleau and A. Hebert +! +!----------------------------------------------------------------------- +! +subroutine THMHSP(p, t) +! return the saturation pressure (Pa) as a function of the temperature (K) +! Ref: Ji. Zhang, January 20, 98 + real :: p, t + double precision :: tcd,zd,pd + character hsmg*131 + ! + tcd=dble(t-273.16) + pd=0.0D0 + IF(tcd .LT. 90.5D0 .OR. tcd.GT.370.74D0) THEN + WRITE(hsmg,*) 'THMHSP: T =',tcd,'C exceeds the valid temperature range', & + & ' for automatic pressure evaluation (90.5<T<370.74)' + call XABORT(hsmg) + ELSEIF (tcd .GT. 320.0D0) THEN + zd = (tcd - 320.0D0)/46.0D0 + pd = 11.442428D6 + (7.0289472D6 + 1.7422423D6*zd)*zd & + + 0.2384117D6*zd**3.680D0 + ELSEIF (tcd .GT. 252.0D0) THEN + zd = (tcd - 252.0D0)/68.0D0 + pd = 4.1333143D6 + (4.75435D6 + 2.124772D6*zd)*zd & + + 0.4299918D6*zd**3.2250D0 + ELSEIF (tcd .GT. 179.0D0) THEN + zd = (tcd - 179.0D0)/73.0D0 + pd = 0.9682855D6 + (1.6569005D6 + 1.1322316D6*zd)*zd & + + 0.3758966D6*zd**3.1460D0 + ELSEIF (tcd .GT. 127.0D0) THEN + zd = (tcd - 127.0D0)/52.0D0 + pd =0.2385152D6 + (0.384338812D6 + 0.2559459D6*zd)*zd & + + 0.089485567D6*zd**3.1740D0 + ELSE + zd = (tcd - 90.50D0)/36.50D0 + pd =0.06736076D6 + (0.09519366D6 + 0.05709235D6*zd)*zd & + + 0.01886846D6*zd**3.2010D0 + ENDIF + p =real(pd) +end subroutine THMHSP +! +subroutine THMHST(p, t) +! return the saturation temperature (K) as a function of the pressure (Pa) +! Ref: Ji. Zhang, January 20, 98 + real :: p, t + double precision :: pd,z,td + character hsmg*131 + ! + pd=p + td=0.0d0 + IF (0.0741494D6 .GT. pd .OR. pd .GT. 21.2082144D6) THEN + WRITE(hsmg,*) 'THMHST: P =',pd,'Pa exceeds the valid pressure range', & + & ' for temperature evaluation (0.0741494<P<21.2082144) MPa' + call XABORT(hsmg) + ELSEIF (pd .GT. 6.9829216D6) THEN + z = (pd - 6.9829216D6)/14.2252928D6 + td = 2.85D2 + (136.2916149D0 - 517.5749172D0*z)*z & + + 465.2833023D0*z**2.0509579D0 + ELSEIF (pd .GT. 2.2074482D6) THEN + z = (pd - 2.2074482D6)/4.7754734D6 + td = 2.175D2 + (110.6079115D0 - 414.5685862D0*z)*z & + + 371.4606747D0*z**2.0575065D0 + ELSEIF (pd .GT. 0.6891798D6) THEN + z = (pd - 0.6891798D6)/1.5182684D6 + td = 1.65D2 + (87.5356881D0 - 423.3068041D0*z)*z & + + 388.271116D0*z**2.0455901D0 + ELSEIF (pd .GT. 0.2241012D6) THEN + z = (pd - 0.2241012D6)/0.4650786D6 + td = 1.25D2 + (66.1987487D0 - 225.285045D0*z)*z & + + 199.0862962D0*z**2.0653628D0 + ELSE + z = (pd - 0.0741494D6)/0.1499518D6 + td = 9.3D1 + (53.0754191D0 - 165.0407938D0*z)*z & + + 143.9653747D0*z**2.0723743D0 + ENDIF + t=REAL(td)+273.16 +end subroutine THMHST +! +subroutine THMHPT(p, t, rho, h, zk, zmu, cp) +! return the remaining thermohydraulics parameters as a function of the pressure (Pa) +! and temperature (K) +! Ref: Ji. Zhang, January 20, 98 + use, intrinsic :: iso_c_binding + implicit real*8(a-h,o-z) + real :: p, t, rho, h, zk, zmu, cp, ps + interface + subroutine free_pT (pd, td, rhod, hd, zkd, zmud, cpd) bind(c, name='free_pT') + use, intrinsic :: iso_c_binding + real(c_double) :: pd, td, rhod, hd, zkd, zmud, cpd + end subroutine free_pT + end interface + ! + tcd=dble(t-273.16) + pd=dble(p) + call THMHSP(ps, t) + psd=dble(ps) + ! + ! compute density in kg/m3 + drho=0.0d0 + IF (90.50D0 .GT. tcd .OR. tcd .GT. 369.0D0) THEN + call XABORT('THMHPT: exceed the valid temperature range') + ELSEIF (tcd .LT. 307.50D0) THEN + zd = (tcd - 90.50D0)/217.0D0 + drho = 1.07065471D3 - (0.1611572D3 + 0.12188254D3*zd)*zd & + - 0.2106382D2*zd**6.830 + ELSEIF (tcd .LT. 350.0D0) THEN + zd = (tcd - 307.50D0)/42.50D0 + drho = 0.7665511D3 - (0.1074816D3 + 0.2506107D2*zd)*zd & + - 0.1042465D2*zd**4.640 + ELSEIF (tcd .LT. 364.0D0) THEN + zd = (tcd - 350.0D0)/14.0D0 + drho = 0.6235838D3 - (0.0678503D3 + 0.01551348D3*zd)*zd & + - 0.7259508D1*zd**4.470 + ELSE + zd = (tcd - 364.0D0)/4.50D0 + drho = 0.5329606D3 - (0.4286569D2 + 0.1064107D2*zd)*zd & + - 0.4761284D1*zd**5 + ENDIF + A = (0.91725D0+0.61D-7*(drho-825.0D0)**2)*(drho+103.65D0)-drho + B = 0.12D-6*psd-0.3D0 + DT = 1.0D6*(370.74D0-tcd) + RR = (B+DT/(22.13D6 - psd))/(B+DT/(pd - psd)) + rho = REAL((drho+(A*RR))) + ! + ! compute specific enthalpy, in J/kg + IF (90.5D0 .GT. tcd .OR. tcd .GT. 358.5D0) THEN + call XABORT('THMHPT: exceed the valid temperature range(1).') + ELSEIF (p .GT. 22.131475E6) THEN + call XABORT('THMHPT: exceed the valid pressure range(1).') + ELSE + H0=0.0d0 + IF (tcd .LT. 257.5D0) THEN + Z = (tcd - 90.5D0)/167.D0 + H0 = 365.515323D0 + (696.60209D0 - 9.3229851D0*Z)*Z & + + 30.7092221D0*Z**3.535D0 + ELSEIF (tcd .LT. 340.D0) THEN + Z = (tcd - 257.5D0)/82.5D0 + H0 = 1083.50185D0 + (388.54695D0 + 40.6830346D0*Z)*Z & + + 21.4058154D0*Z**4.79D0 + ELSEIF (tcd .LT. 364.D0) THEN + Z = (tcd - 340.D0)/24.D0 + H0 = 1534.137695D0 + (166.53D0 + 27.8460448D0*Z)*Z & + + 15.9652752D0*Z**5.67D0 + ELSE + Z = (tcd - 364.D0)/5.D0 + H0 = 1744.47897D0 + (65.11525D0 + 15.3342016D0*Z)*Z & + + 8.2093984D0*Z**5.74D0 + ENDIF + A = (0.9769D0 - 0.695D-6*(tcd - 199.4D0)**2)*(H0+27.93D0) - H0 + B = 0.13D-1*tcd - 2.D0 + DT = 1.D06*(370.74D0 - tcd) + HH = (B + DT/(22.131475D06 - psd))/(B+DT/(pd - psd)) + h = REAL(H0 + A*HH)*1.0E3 + ENDIF + ! + ! compute specific heat capacity, in J/kg.K + IF (90.5 .GT. tcd .OR. tcd .GT. 354.5) THEN + call XABORT('THMHPT: exceed the valid temperature range(2).') + ELSEIF (p .GT. 20.06E6) THEN + call XABORT('THMHPT: exceed the valid pressure range(2).') + ELSE + CP0=0.0d0 + IF (tcd .LT. 216.D0) THEN + Z = (tcd - 90.5D0)/125.5D0 + CP0 = 0.2398399D0 + (0.7260874D-2 - 0.8715753D-2*Z)*Z & + - 0.1067229D-1*Z**2.43D0 + CP0 = 1.D0/CP0 + ELSEIF (tcd .LT. 289.D0) THEN + Z = (tcd - 216.D0)/73.D0 + CP0 = 4.3914986D0 + (0.4050098D0 + 0.2650923D0*Z)*Z & + + 0.152426D0*Z**4.26D0 + ELSEIF (tcd .LT. 334.D0) THEN + Z = (tcd - 289.D0)/45.D0 + CP0 = 0.1917903D0 - (0.3592811D-1 + 0.1396726D-1*Z)*Z & + - 0.5187553D-2*Z**4.07D0 + CP0 = 1.D0/CP0 + ELSEIF (tcd .LT. 357.D0) THEN + Z = (tcd - 334.D0)/23.D0 + CP0 = 0.1367074D0 - (0.4343216D-1 + 0.1360508D-1*Z)*Z & + - 0.5536208D-2*Z**3.82D0 + CP0 = 1.D0/CP0 + ELSE + Z = (tcd - 357.D0)/9.5D0 + CP0 = 0.07413399D0 - (0.3791352D-1 + 0.6539416D-2*Z)*Z & + - 0.2756629D-2*Z**2.58D0 + CP0 = 1.D0/CP0 + ENDIF + A = -0.19878D0 + (1.521D0 - 0.393D0*CP0)*CP0 + B = -0.293594D0 + (0.45876D0 + 0.57448D-02*CP0)*CP0 + DT = 1.D06*(370.74D0 - tcd) + CC = B + DT/(pd - psd) + cp = REAL(CP0 + A/CC)*1.0E3 + ENDIF + ! + ! use thermal conductivity and dynamic viscosity of light water + td=dble(t) + call free_pT(pd, td, rhod, hd, zkd, zmud, cpd) + zk=real(zkd) + zmu=real(zmud) +end subroutine THMHPT +! +subroutine THMHTX(t, x, rho, h, zk, zmu, cp) +! return the remaining thermohydraulics parameters as a function of the temperature (K) +! and quality +! Ref: Ji. Zhang, January 20, 98 + use, intrinsic :: iso_c_binding + implicit real*8(a-h,o-z) + real :: t, x, rho, h, zk, zmu, cp + interface + subroutine free_Tx (td, xd, rhod, hd, zkd, zmud, cpd) bind(c, name='free_Tx') + use, intrinsic :: iso_c_binding + real(c_double) :: td, xd, rhod, hd, zkd, zmud, cpd + end subroutine free_Tx + end interface + ! + tcd=dble(t-273.16) + RO = 0.0D0 + H0 = 0.0D0 + CP0 = 0.0D0 + IF (x.EQ.0.0) THEN + ! saturated liquid + if (90.5D0 .GT. tcd .OR. tcd .GT. 367.D0) then + call XABORT('THMHTX: the valid range of temperature is exceeded(1).') + ENDIF + ! + ! compute density in kg/m3 + IF (tcd .LT. 307.5D0) then + Z = (tcd - 90.5D0)/217.D0 + RO = 1.07065471D3 - (0.1611572D3 + 0.12188254D3*Z)*Z & + - 0.2106382D2*Z**6.83D0 + ELSEIF (tcd .LT. 350.D0) then + Z = (tcd - 307.5D0)/42.5D0 + RO = 0.7665511D3 - (0.1074816D3 + 0.2506107D2*Z)*Z & + - 0.1042465D2*Z**4.64D0 + ELSEIF (tcd .LT. 364.D0) then + Z = (tcd - 350.D0)/14.D0 + RO = 0.6235838D3 - (0.0678503D3 + 0.01551348D3*Z)*Z & + - 0.7259508D1*Z**4.47D0 + ELSE + Z = (tcd - 364.D0)/4.5D0 + RO = 0.5329606D3 - (0.4286569D2 + 0.1064107D2*Z)*Z & + - 0.4761284D1*Z**5 + ENDIF + ! + ! compute specific enthalpy, in J/kg + IF (tcd .LT. 257.5D0) then + Z = (tcd - 90.5D0)/167.D0 + H0 = 365.515323D0 + (696.60209D0 - 9.3229851D0*Z)*Z & + + 30.7092221D0*Z**3.535D0 + ELSEIF (tcd .LT. 340.D0) then + Z = (tcd - 257.5D0)/82.5D0 + H0 = 1083.50185D0 + (388.54695D0 + 40.6830346D0*Z)*Z & + + 21.4058154D0*Z**4.79D0 + ELSEIF (tcd .LT. 364.D0) then + Z = (tcd - 340.D0)/24.D0 + H0 = 1534.137695D0 + (166.53D0 + 27.8460448D0*Z)*Z & + + 15.9652752D0*Z**5.67D0 + ELSE + Z = (tcd - 364.D0)/5.D0 + H0 = 1744.47897D0 + (65.11525D0 + 15.3342016D0*Z)*Z & + + 8.2093984D0*Z**5.74D0 + ENDIF + ! + ! compute specific heat capacity at constant pressure, in J/kg/K + IF (tcd .LT. 216.D0) then + Z = (tcd - 90.5D0)/125.5D0 + CP0 = 0.2398399D0 + (0.7260874D-2 - 0.8715753D-2*Z)*Z & + - 0.1067229D-1*Z**2.43D0 + CP0 = 1.D0/CP0 + ELSEIF (tcd .LT. 289.D0) then + Z = (tcd - 216.D0)/73.D0 + CP0 = 4.3914986D0 + (0.4050098D0 + 0.2650923D0*Z)*Z & + + 0.152426D0*Z**4.26D0 + ELSEIF (tcd .LT. 334.D0) then + Z = (tcd - 289.D0)/45.D0 + CP0 = 0.1917903D0 - (0.3592811D-1 + 0.1396726D-1*Z)*Z & + - 0.5187553D-2*Z**4.07D0 + CP0 = 1.D0/CP0 + ELSEIF (tcd .LT. 357.D0) then + Z = (tcd - 334.D0)/23.D0 + CP0 = 0.1367074D0 - (0.4343216D-1 + 0.1360508D-1*Z)*Z & + - 0.5536208D-2*Z**3.82D0 + CP0 = 1.D0/CP0 + ELSE + Z = (tcd - 357.D0)/9.5D0 + CP0 = 0.07413399D0 - (0.3791352D-1 + 0.6539416D-2*Z)*Z & + - 0.2756629D-2*Z**2.58D0 + CP0 = 1.D0/CP0 + ENDIF + ELSEIF (x.EQ.1.0) THEN + ! saturated steam + IF (90.5D0 .GT. tcd .OR. tcd .GT. 367.D0) then + call XABORT('THMHTX: the valid range of temperature is exceeded(2).') + ENDIF + ! + ! compute density in kg/m3 + IF (tcd .GT. 350.D0) then + Z = (tcd - 350.D0)/16.D0 + RO = 7.5017113D0 - (2.7448665D0 - 0.4712976D-1*Z)*Z & + - 0.1461081D0*Z**5.45D0 + RO = 1.D3/RO + ELSEIF (tcd .GT. 288.D0) then + Z = (tcd - 288.D0)/62.D0 + RO = 23.2557129D0 - (24.2703096D0 - 12.7121893D0*Z)*Z & + - 4.1958813D0*Z**2.81D0 + RO = 1.D3/RO + ELSEIF (tcd .GT. 221.D0) then + Z = (tcd - 221.D0)/67.D0 + RO = 0.01319205D3 + (0.1687167D2 + 0.9533432D1*Z)*Z & + + 0.3402844D1*Z**3.69D0 + ELSEIF (tcd .GT. 147.5D0) then + Z = (tcd - 147.5D0)/73.5D0 + RO = 0.2595185D1 + (0.4966204D1 + 0.3980025D1*Z)*Z & + + 0.1650632D1*Z**3.382D0 + ELSE + Z = (tcd - 90.5D0)/57.D0 + RO = 0.451542D0 + (0.9337486D0 + 0.8179223D0*Z)*Z & + + 0.3919721D0*Z**3.27D0 + ENDIF + ! + ! compute specific enthalpy, in J/kg + IF (tcd .LT. 259.D0) then + Z = (tcd - 90.5D0)/168.5D0 + H0 = 2465.02D0 + (257.038325D0 - 69.298269D0*Z)*Z & + - 59.547036D0*Z**3.39D0 + ELSEIF (tcd .LT. 333.D0) then + Z = (tcd - 259.D0)/74.D0 + H0 = 2593.21302D0 - (36.63666D0 + 70.6712028D0*Z)*Z & + - 26.1578672D0*Z**4.41D0 + ELSEIF (tcd .LT. 359.D0) then + Z = (tcd - 333.D0)/26.D0 + H0 = 2459.74729D0 - (103.06374D0 + 40.5743371D0*Z)*Z & + - 17.2902029D0*Z**4.76D0 + ELSE + Z = (tcd - 359.D0)/8.5D0 + H0 = 2298.81901D0 - (87.129505D0 + 27.7163491D0*Z)*Z & + - 14.0347359D0*Z**5.2D0 + ENDIF + ! + ! compute specific heat capacity at constant pressure, in J/kg/K + IF (tcd .LT. 208.D0) then + Z = (tcd - 90.5D0)/117.5D0 + CP0 = 1.8689755D0 + (0.3394869D0 + 0.2728998D0*Z)*Z & + + 0.2686182D0*Z**3.507D0 + ELSEIF (tcd .LT. 270.D0) then + Z = (tcd - 208.D0)/62.D0 + CP0 = 2.7499805D0 + (0.9642085D0 + 0.4429098D0*Z)*Z & + + 0.141205D0*Z**3.945D0 + ELSEIF (tcd .LT. 339.D0) then + Z = (tcd - 270.D0)/69.D0 + CP0 = 0.2326499D0 - (0.1449925D0 - 0.19935345D-2*Z)*Z & + - 0.441272D-2*Z**3.96D0 + CP0 = 1.D0/CP0 + ELSEIF (tcd .LT. 363.D0) then + Z = (tcd - 339.D0)/24.D0 + CP0 = 0.08523823D0 - (0.5512341D-1 + 0.3706342D-2*Z)*Z & + - 0.2012056D-2*Z**4.26D0 + ELSE + Z = (tcd - 363.D0)/4.D0 + CP0 = 0.02439642D0 - (0.1185124D-1 + 0.4619397D-3*Z)*Z & + - 0.1003777D-3*Z**2.4D0 + CP0 = 1.D0/CP0 + ENDIF + ELSE + CALL XABORT('THMHTX: quality = 0.0 or 1.0 expected.') + ENDIF + rho = REAL(RO) + h = REAL(H0)*1.0E3 + cp = REAL(CP0)*1.0E3 + ! + ! use thermal conductivity and dynamic viscosity of light water + td=dble(t) + xd=dble(x) + call free_Tx(td, xd, rhod, hd, zkd, zmud, cpd) + zk=real(zkd) + zmu=real(zmud) +end subroutine THMHTX diff --git a/Utilib/src/MSRILU.f b/Utilib/src/MSRILU.f new file mode 100644 index 0000000..c84767d --- /dev/null +++ b/Utilib/src/MSRILU.f @@ -0,0 +1,113 @@ +*DECK MSRILU + SUBROUTINE MSRILU(N,LC,IM,MCU,JU,DIAGF,CF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* In-place ILU0 decomposition of a matrix store in MSR format. +* The resulting matrix is in "L\U-I" format with inversed diagonal elements +* It is assumed that each line of the matrix is sorted by increasing +* column index. +* +*Reference +* Y. Saad, "Iterative Methods for Sparse Linear Systems", +* PWS Publishing Company, Boston, 1996 +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N size of the matrix. +* LC dimension of IM. +* IM elements of row i in MCU(IM(i):IM(i+1)-1) +* MCU +* JU MCU(JU(i):IM(i+1)) corresponds to U. +* MCU(IM(i)+1:JU(i)-1) correspond to L. +* +* Parameters: input/output +* DIAGF diagonal elements of the matrix to process / U (inversed diagonal). +* CF non-diagonal elements of the matrix to process / L and U. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,LC,IM(N+1),MCU(LC),JU(N) + DOUBLE PRECISION DIAGF(N),CF(LC) +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION EPS + PARAMETER(EPS=1D-7) + INTEGER I,K,J,H,IK,IJ,KJ,IH + DOUBLE PRECISION E + INTEGER, ALLOCATABLE, DIMENSION(:) :: IW +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IW(N)) +* + IW(:N)=0 +*--- +* LOOP OVER LINE INDEX I +*--- + DO I=1,N +* store component H in relation with I + DO IH=IM(I)+1,IM(I+1) + H=MCU(IH) + IF (H.GT.0) IW(H)=IH + ENDDO +* --- +* LOOP OVER LINE K < I IN RELATION WITH I +* --- + DO IK=IM(I)+1,JU(I)-1 + K=MCU(IK) + IF (K.GT.0) THEN +* entry (I>K,K) + E=DIAGF(K)*CF(IK) + CF(IK)=E +* --- +* LOOP OVER COLUMN J > K IN RELATION WITH K +* --- + DO KJ=JU(K),IM(K+1) + J=MCU(KJ) +* entry (I>K,J>K) + IF (I.EQ.J) THEN ! diagonal term + DIAGF(J)=DIAGF(J)-E*CF(KJ) + ELSEIF(IW(J).GT.0) THEN ! if J is in relation with I + IJ=IW(J) + CF(IJ)=CF(IJ)-E*CF(KJ) + ENDIF + ENDDO + ENDIF + ENDDO + IF (ABS(DIAGF(I)).GT.EPS) THEN + DIAGF(I)=1.0/DIAGF(I) + ELSE + WRITE(6,*) 'I=',I,' PIVOT=',DIAGF(I) + CALL PRINDM('DIAGF ',DIAGF,N) + CALL PRINDM('CF ',CF,LC) + CALL XABORT('MSRILU: ZERO PIVOT') + ENDIF +* reset IW + DO IH=IM(I)+1,IM(I+1) + H=MCU(IH) + IF (H.GT.0) THEN + IW(H)=0 + ENDIF + ENDDO + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IW) + RETURN + END diff --git a/Utilib/src/MSRLUS.f b/Utilib/src/MSRLUS.f new file mode 100644 index 0000000..3b25713 --- /dev/null +++ b/Utilib/src/MSRLUS.f @@ -0,0 +1,98 @@ +*DECK MSRLUS + SUBROUTINE MSRLUS(LFORW,N,LC,IM,MCU,JU,ILUDF,ILUCF,XIN,XOUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve LU y = x where LU is stored in the "L\U-I" form in MSR format. +* Can be use "in-place" i.e. XOUT=XIN. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LFORW flag set to .false. to transpose the coefficient matrix. +* N order of the system. +* LC dimension of IM. +* IM elements of row i in MCU(IM(i):IM(i+1)-1) +* MCU +* JU MCU(JU(i):IM(i+1)) corresponds to U. +* MCU(IM(i)+1:JU(i)-1) correspond to L. +* ILUDF diagonal elements of U (inversed diagonal). +* ILUCF non-diagonal elements of L and U. +* XIN input vector x. +* +*Parameters: output +* XOUT output vector y. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,LC,IM(N+1),MCU(LC),JU(N) + REAL ILUDF(N),ILUCF(LC) + DOUBLE PRECISION XIN(N),XOUT(N) + LOGICAL LFORW +*--- +* LOCAL VARIABLES +*--- + INTEGER I,J,IJ + IF(LFORW) THEN +*--- +* FORWARD SOLVE +*--- + DO I=1,N + XOUT(I)=XIN(I) + DO IJ=IM(I)+1,JU(I)-1 + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(I)=XOUT(I) + 1 -ILUCF(IJ)*XOUT(J) + ENDDO + ENDDO +*--- +* BACKWARD SOLVE +*--- + DO I=N,1,-1 + DO IJ=JU(I),IM(I+1) + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(I)=XOUT(I) + 1 -ILUCF(IJ)*XOUT(J) + ENDDO + XOUT(I)=ILUDF(I)*XOUT(I) + ENDDO + ELSE +*--- +* FORWARD SOLVE (TRANSPOSED LINEAR SYSTEM) +*--- + DO I=1,N + XOUT(I)=XIN(I) + ENDDO + DO I=1,N + DO IJ=JU(I),IM(I+1) + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(J)=XOUT(J) + 1 -ILUDF(I)*ILUCF(IJ)*XOUT(I) + ENDDO + ENDDO +*--- +* BACKWARD SOLVE (TRANSPOSED LINEAR SYSTEM) +*--- + DO I=N,1,-1 + DO IJ=IM(I)+1,JU(I)-1 + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(J)=XOUT(J) + 1 -ILUCF(IJ)*XOUT(I) + ENDDO + ENDDO + ENDIF +* + RETURN + END diff --git a/Utilib/src/MSRLUS1.f b/Utilib/src/MSRLUS1.f new file mode 100644 index 0000000..b7952e8 --- /dev/null +++ b/Utilib/src/MSRLUS1.f @@ -0,0 +1,101 @@ +*DECK MSRLUS + SUBROUTINE MSRLUS1(LFORW,N,LC,IM,MCU,JU,ILUDF,CF,XIN,XOUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve LU y = x where LU is stored in the "L\U-I" form in MSR format. +* Can be use "in-place" i.e. XOUT=XIN. +* Special case for which the non-diagonal elements of U +* are the same as the original matrix. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LFORW flag set to .false. to transpose the coefficient matrix. +* N order of the system. +* LC dimension of MCU. +* IM elements of row i in MCU(IM(i):IM(i+1)-1) +* MCU +* JU MCU(JU(i):IM(i+1)) corresponds to U. +* MCU(IM(i)+1:JU(i)-1) correspond to L. +* ILUDF diagonal elements of U (inversed diagonal). +* CF non-diagonal elements of the original matrix. +* XIN input vector x. +* +*Parameters: output +* XOUT output vector y. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,LC,IM(N+1),MCU(LC),JU(N) + REAL ILUDF(N),CF(LC) + DOUBLE PRECISION XIN(N),XOUT(N) + LOGICAL LFORW +*--- +* LOCAL VARIABLES +*--- + INTEGER I,J,IJ + IF(LFORW) THEN +*--- +* FORWARD SOLVE +*--- + DO I=1,N + XOUT(I)=XIN(I) + DO IJ=IM(I)+1,JU(I)-1 + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(I)=XOUT(I) + 1 -ILUDF(J)*CF(IJ)*XOUT(J) + ENDDO + ENDDO +*--- +* BACKWARD SOLVE +*--- + DO I=N,1,-1 + XOUT(I)=ILUDF(I)*XOUT(I) + DO IJ=JU(I),IM(I+1) + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(I)=XOUT(I) + 1 -ILUDF(I)*CF(IJ)*XOUT(J) + ENDDO + ENDDO + ELSE +*--- +* FORWARD SOLVE (TRANSPOSED LINEAR SYSTEM) +*--- + DO I=1,N + XOUT(I)=XIN(I) + ENDDO + DO I=1,N + DO IJ=JU(I),IM(I+1) + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(J)=XOUT(J) + 1 -ILUDF(I)*CF(IJ)*XOUT(I) + ENDDO + ENDDO +*--- +* BACKWARD SOLVE (TRANSPOSED LINEAR SYSTEM) +*--- + DO I=N,1,-1 + XOUT(I)=ILUDF(I)*XOUT(I) + DO IJ=IM(I)+1,JU(I)-1 + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) XOUT(J)=XOUT(J) + 1 -ILUDF(J)*CF(IJ)*XOUT(I) + ENDDO + ENDDO + ENDIF + RETURN +* + END diff --git a/Utilib/src/MSRLUS2.f b/Utilib/src/MSRLUS2.f new file mode 100644 index 0000000..d50c33b --- /dev/null +++ b/Utilib/src/MSRLUS2.f @@ -0,0 +1,141 @@ +*DECK MSRLUS + SUBROUTINE MSRLUS2(LFORW,N,LC,LC0,IM,MCU,IM0,MCU0,JU,ILUDF,ILUCF, + 1 CF,XIN,XOUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve LU y = x where LU is stored in the "L\U-I" form in MSR format. +* Can be use "in-place" i.e. XOUT=XIN. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LFORW flag set to .false. to transpose the coefficient matrix. +* N order of the system. +* LC dimension of MCU. +* LC0 dimension of MCU0. +* IM elements of row i in MCU(IM(i):IM(i+1)-1) for CF. +* MCU +* IM0 elements of row i in MCU0(IM0(i):IM0(i+1)-1) for ILUCF. +* MCU0 +* JU MCU(JU(i):IM(i+1)) corresponds to U. +* MCU(IM(i)+1:JU(i)-1) correspond to L. +* ILUDF diagonal elements of U (inversed diagonal). +* ILUCF non-diagonal elements of U which differs from CF. +* CF non-diagonal elements of the original matrix. +* XIN input vector x. +* +*Parameters: output +* XOUT output vector y. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,LC,LC0,IM(N+1),MCU(LC),IM0(N+1),MCU0(LC0),JU(N) + REAL ILUDF(N),ILUCF(LC0),CF(LC) + DOUBLE PRECISION XIN(N),XOUT(N) + LOGICAL LFORW +*--- +* LOCAL VARIABLES +*--- + INTEGER I,J,IJ,IK + REAL ICFIJ + IF(LFORW) THEN +*--- +* FORWARD SOLVE +*--- + DO I=1,N + XOUT(I)=XIN(I) + DO IJ=IM(I)+1,JU(I)-1 + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) THEN + DO IK=IM0(I)+1,IM0(I+1) + IF (MCU0(IK).EQ.J) THEN + ICFIJ=ILUCF(IK) + GOTO 10 + ENDIF + ENDDO + ICFIJ=ILUDF(J)*CF(IJ) + 10 CONTINUE + XOUT(I)=XOUT(I)-ICFIJ*XOUT(J) + ENDIF + ENDDO + ENDDO +*--- +* BACKWARD SOLVE +*--- + DO I=N,1,-1 + DO IJ=JU(I),IM(I+1) + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) THEN + DO IK=IM0(I)+1,IM0(I+1) + IF (MCU0(IK).EQ.J) THEN + ICFIJ=ILUCF(IK) + GOTO 20 + ENDIF + ENDDO + ICFIJ=CF(IJ) + 20 CONTINUE + XOUT(I)=XOUT(I)-ICFIJ*XOUT(J) + ENDIF + ENDDO + XOUT(I)=ILUDF(I)*XOUT(I) + ENDDO + ELSE +*--- +* FORWARD SOLVE +*--- + DO I=1,N + XOUT(I)=XIN(I) + ENDDO + DO I=1,N + DO IJ=JU(I),IM(I+1) + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) THEN + DO IK=IM0(I)+1,IM0(I+1) + IF (MCU0(IK).EQ.J) THEN + ICFIJ=ILUCF(IK) + GOTO 30 + ENDIF + ENDDO + ICFIJ=ILUDF(I)*CF(IJ) + 30 CONTINUE + XOUT(J)=XOUT(J)-ICFIJ*XOUT(I) + ENDIF + ENDDO + ENDDO +*--- +* BACKWARD SOLVE +*--- + DO I=N,1,-1 + XOUT(I)=ILUDF(I)*XOUT(I) + DO IJ=IM(I)+1,JU(I)-1 + J=MCU(IJ) + IF ((J.GT.0).AND.(J.LE.N)) THEN + DO IK=IM0(I)+1,IM0(I+1) + IF (MCU0(IK).EQ.J) THEN + ICFIJ=ILUCF(IK) + GOTO 40 + ENDIF + ENDDO + ICFIJ=CF(IJ) + 40 CONTINUE + XOUT(J)=XOUT(J)-ILUDF(J)*ICFIJ*XOUT(I) + ENDIF + ENDDO + ENDDO + ENDIF +* + RETURN + END diff --git a/Utilib/src/Makefile b/Utilib/src/Makefile new file mode 100644 index 0000000..2bb6d73 --- /dev/null +++ b/Utilib/src/Makefile @@ -0,0 +1,180 @@ +#--------------------------------------------------------------------------- +# +# Makefile for building the Utilib library +# Author : A. Hebert (2018-5-10) +# +#--------------------------------------------------------------------------- +# +ARCH = $(shell uname -m) +ifneq (,$(filter $(ARCH),aarch64 arm64)) + nbit = +else + ifneq (,$(filter $(ARCH),i386 i686)) + nbit = -m32 + else + nbit = -m64 + endif +endif + +DIRNAME = $(shell uname -sm | sed 's/[ ]/_/') +OS = $(shell uname -s | cut -d"_" -f1) +opt = -O -g +ifeq ($(openmp),1) + COMP = -fopenmp +else + COMP = +endif + +ifeq ($(intel),1) + fcompiler = ifort + ccompiler = icc +else + ifeq ($(nvidia),1) + fcompiler = nvfortran + ccompiler = nvc + else + ifeq ($(llvm),1) + fcompiler = flang-new + ccompiler = clang + else + fcompiler = gfortran + ccompiler = gcc + endif + endif +endif + +ifeq ($(OS),AIX) + python_version_major := 2 +else + python_version_full := $(wordlist 2,4,$(subst ., ,$(shell python --version 2>&1))) + python_version_major := $(word 1,${python_version_full}) + ifneq ($(python_version_major),2) + python_version_major := 3 + endif +endif + +ifeq ($(OS),Darwin) + ifeq ($(openmp),1) + ccompiler = gcc-14 + endif + F90 = $(fcompiler) + C = $(ccompiler) + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC +else +ifeq ($(OS),Linux) + F90 = $(fcompiler) + C = $(ccompiler) + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC +else +ifeq ($(OS),CYGWIN) + F90 = $(fcompiler) + C = $(ccompiler) + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC +else +ifeq ($(OS),SunOS) + fcompiler = + F90 = f90 + C = cc + CFLAGS = $(nbit) + FFLAGS = $(nbit) -s -ftrap=%none + FFLAG77 = $(nbit) -s -ftrap=%none +else +ifeq ($(OS),AIX) + fcompiler = + opt = -O4 + DIRNAME = AIX + F90 = xlf90 + C = cc + CFLAGS = -qstrict + FFLAGS = -qstrict -qmaxmem=-1 -qsuffix=f=f90 + FFLAG77 = -qstrict -qmaxmem=-1 -qxlf77=leadzero -qfixed +else + $(error $(OS) is not a valid OS) +endif +endif +endif +endif +endif +ifeq ($(fcompiler),gfortran) + ifneq (,$(filter $(ARCH),i386 i686 x86_64)) + summary = + else + summary = -ffpe-summary=none + endif + ifeq ($(OS),Darwin) + summary = -ffpe-summary=none + endif + FFLAGS += -Wall $(summary) + FFLAG77 += -Wall -frecord-marker=4 $(summary) +endif + +ifeq ($(intel),1) + FFLAGS = -fPIC + FFLAG77 = -fPIC + lib = ../lib/$(DIRNAME)_intel + lib_module = ../lib/$(DIRNAME)_intel/modules +else + ifeq ($(nvidia),1) + lib = ../lib/$(DIRNAME)_nvidia + lib_module = ../lib/$(DIRNAME)_nvidia/modules + else + ifeq ($(llvm),1) + lib = ../lib/$(DIRNAME)_llvm + lib_module = ../lib/$(DIRNAME)_llvm/modules + FFLAGS += -mmlir -fdynamic-heap-array + LFLAGS += -lclang_rt.osx + else + lib = ../lib/$(DIRNAME) + lib_module = ../lib/$(DIRNAME)/modules + endif + endif +endif + +SRCC = $(shell ls *.c) +SRC77 = $(shell ls *.f) +ifeq ($(python_version_major),2) + SRC90 = $(shell python ../../script/make_depend.py *.f90) +else + SRC90 = $(shell python3 ../../script/make_depend_py3.py *.f90) +endif +OBJC = $(SRCC:.c=.o) +OBJ90 = $(SRC90:.f90=.o) +OBJ77 = $(SRC77:.f=.o) +all : libUtilib.a + @echo 'Utilib: fflags=' $(FFLAGS) +ifeq ($(openmp),1) + @echo 'Utilib: openmp is defined' +endif +ifeq ($(intel),1) + @echo 'Utilib: intel is defined' +endif +ifeq ($(nvidia),1) + @echo 'Utilib: nvidia is defined' +endif +ifeq ($(llvm),1) +] @echo 'Utilib: llvm is defined' +endif + @echo "Utilib: python version=" ${python_version_major} +%.o : %.c + $(C) $(CFLAGS) $(opt) $(COMP) -c $< -o $@ +%.o : %.f90 + $(F90) $(FFLAGS) $(opt) $(COMP) $(INCLUDE) -c $< -o $@ +%.o : %.f + $(F90) $(FFLAG77) $(opt) $(COMP) -c $< -o $@ +all: $(lib_module) +$(lib_module)/: + mkdir -p $(lib_module)/ +$(lib)/: $(lib_module)/ + mkdir -p $(lib)/ +libUtilib.a: $(OBJC) $(OBJ90) $(OBJ77) $(lib)/ + ar r $@ $(OBJC) $(OBJ90) $(OBJ77) + cp $@ $(lib)/$@ + cp *.mod $(lib_module) +clean: + /bin/rm -f *.o *.mod *.a diff --git a/Utilib/src/PLLEMK.f b/Utilib/src/PLLEMK.f new file mode 100644 index 0000000..d50db6f --- /dev/null +++ b/Utilib/src/PLLEMK.f @@ -0,0 +1,165 @@ +*DECK PLLEMK
+ SUBROUTINE PLLEMK(N,M,EPS,IMPR,P,IROW,ICOL,IERR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* This subroutine solve the parametric linear complementary problem.
+* PLLEMK = Linear Programming LEMKe
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s):
+* A. Hebert and T. Falcon
+*
+*Parameters: input
+* N number of control variables.
+* M number of constraints.
+* EPS tolerence used for pivoting.
+* IMPR print flag.
+* P coefficient matrix.
+* IROW permutation vector for row elements.
+* ICOL permutation vector for column elements.
+*
+*Parameters: ouput
+* P coefficient matrix.
+* IROW permutation vector for row elements.
+* ICOL permutation vector for column elements.
+* IERR return code (=0: normal completion).
+*
+*-----------------------------------------------------------------------
+*
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ INTEGER M,N,IERR,IMPR,IROW(N),ICOL(N+1)
+ DOUBLE PRECISION EPS,P(N,M)
+*----
+* LOCAL VARIABLES
+*----
+ DOUBLE PRECISION WWW,S
+ INTEGER MNOP,NP1,IC,L,I,J,K,JJ,J1,LGAR
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PLJ
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(PLJ(M))
+*
+ MNOP = N + M
+ NP1 = N + 1
+ IC = 0
+*
+ S = 0.0D0
+ L = 0
+*
+ DO I=1,N
+ P(I,NP1) = 1.0D0
+ IF(P(I,M).GE.0.0D0) CYCLE
+ WWW = P(I,M)
+ IF(WWW.LE.S) THEN
+ L = I
+ S = WWW
+ ENDIF
+ ENDDO
+*
+ IF(L.EQ.0) GO TO 30
+ LGAR = L
+*
+ K = NP1
+*
+ 10 IC = IC + 1
+ IF(IC.GT.MNOP) THEN
+ IERR = 1
+ GOTO 40
+ ENDIF
+*
+ IF(IMPR.GE.5) WRITE (6,1000) L,K
+ IF(IMPR.GE.6) THEN
+ DO J=1,M,12
+ JJ = MIN0(J+11,M)
+ WRITE (6,3000) (J1,J1=J,JJ)
+ DO I=1,N
+ WRITE (6,4000) I,(P(I,J1),J1=J,JJ)
+ ENDDO
+ IF(JJ.NE.M) WRITE (6,5000)
+ ENDDO
+ ENDIF
+*
+ CALL PLPIVT(N,M,L,K,P,IROW,ICOL)
+*
+ IF(ICOL(K).EQ.-NP1) GOTO 30
+ DO J=1,NP1
+ IF(J.EQ.K) CYCLE
+ IF(IABS(ICOL(K)).EQ.IABS(ICOL(J))) THEN
+ K = J
+ GOTO 20
+ ENDIF
+ ENDDO
+*
+ IERR = 2
+ GOTO 40
+*
+ 20 DO I=1,N
+ IF(P(I,K)/P(I,M).LT.-EPS) THEN
+ PLJ(I) = -P(I,M)/P(I,K)
+ ELSE
+ PLJ(I) = 1.0D50
+ ENDIF
+ ENDDO
+*
+ S = PLJ(LGAR)
+ L = LGAR
+*
+ IF(IMPR.GE.7) THEN
+ WRITE (6,*) 'K=',K
+ WRITE (6,6000) L,(PLJ(I),I=1,N)
+ ENDIF
+*
+ DO I=1,N
+ WWW = PLJ(I)
+ IF((ABS(WWW-S).GT.ABS(S)*EPS).AND.(WWW.LT.S)) THEN
+ S = WWW
+ L = I
+ ENDIF
+ ENDDO
+*
+ IF(S.EQ.1.0D50) THEN
+ IERR = 3
+ GOTO 40
+ ENDIF
+*
+ GOTO 10
+ 30 IERR = 0
+*
+ 40 IF(IMPR.GE.6) THEN
+ WRITE (6,2000) IC
+ DO J=1,M,12
+ JJ = MIN0(J+11,M)
+ WRITE (6,3000) (J1,J1=J,JJ)
+ DO I=1,N
+ WRITE (6,4000) I,(P(I,J1),J1=J,JJ)
+ ENDDO
+ IF(JJ.NE.M) WRITE (6,5000)
+ ENDDO
+ ENDIF
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(PLJ)
+ RETURN
+*
+1000 FORMAT (//,10X,'+ + + + + MATRIX P(N,N+3) :',5X,'PIVOT = (',
+ > I4,' ,',I4,' )'/)
+2000 FORMAT (//,10X,'NUMBER OF PIVOTS =',I5,
+ > //,10X,'+ + + + + FINAL MATRIX P(N,N+3) :'/)
+3000 FORMAT (5X,12I12)
+4000 FORMAT (1X,I4,1P,10E12.4/(5X,1P,10E12.4))
+5000 FORMAT (//)
+6000 FORMAT (//,10X,'LGAR =',I4/(1X,1P,8E12.4))
+ END
diff --git a/Utilib/src/PLLINR.f b/Utilib/src/PLLINR.f new file mode 100644 index 0000000..ac7b710 --- /dev/null +++ b/Utilib/src/PLLINR.f @@ -0,0 +1,138 @@ +*DECK PLLINR
+ SUBROUTINE PLLINR(N0,M1,MAXM,COUT,APLUS,BPLUS,BINF,BSUP,XOBJ,F,
+ > EPS,IMPR,IERR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Minimizes a linear programming problem using LEMKE pivot.
+* PLLINR=Linear Programming LINeaR problem resolution
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s):
+* A. Hebert
+*
+*Parameters: input
+* N0 number of control variables.
+* M1 number of constraints.
+* MAXM first dimension of matrix APLUS.
+* COUT costs of control variables.
+* APLUS coefficient matrix for the linear constraints.
+* BPLUS right hand sides corresponding to the coefficient matrix.
+* BINF lower bounds of control variables.
+* BSUP upper bounds of control variables.
+* EPS tolerence used for pivoting.
+* IMPR print flag.
+*
+*Parameters: ouput
+* XOBJ control variables.
+* F objective function.
+* IERR return code (=0: normal completion).
+*
+*-----------------------------------------------------------------------
+*
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ INTEGER N0,M1,MAXM,IMPR,IERR
+ DOUBLE PRECISION BPLUS(M1),BINF(N0),BSUP(N0),XOBJ(N0),EPS,
+ > APLUS(MAXM,N0),COUT(N0),F
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER N,NP1,NP2,I,J,II,IR
+ DOUBLE PRECISION XVAL
+ CHARACTER*4 ROW(7)
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IROW,ICOL
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: P
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(IROW(2*N0+M1),ICOL(2*N0+M1+1))
+ ALLOCATE(P(2*N0+M1,2*N0+M1+2))
+*----
+* SET-UP AND SOLVE THE PARAMETRIC COMPLEMENTARITY PROBLEM.
+*----
+ N=2*N0+M1
+ NP1=N+1
+ NP2=N+2
+*
+ P(:N,:NP2)=0.0D0
+ DO I=1,N0
+ P(I,NP2)=COUT(I)
+ P(N0+M1+I,NP2)=BSUP(I) - BINF(I)
+ P(I,N0+M1+I)= 1.0D0
+ P(N0+M1+I,I)=-1.0D0
+ DO J=1,M1
+ P(I,N0+J)=APLUS(J,I)
+ ENDDO
+ ENDDO
+*
+ DO I=1,M1
+ XVAL=0.0D0
+ DO J=1,N0
+ XVAL=XVAL+APLUS(I,J)*BINF(J)
+ ENDDO
+ P(N0+I,NP2)=BPLUS(I) - XVAL
+ DO J=1,N0
+ P(N0+I,J)=-APLUS(I,J)
+ ENDDO
+ ENDDO
+*
+ DO 50 I=1,N
+ IROW(I) = I
+ ICOL(I) =-I
+ P(I,NP1)=1.0D0
+ 50 CONTINUE
+ ICOL(NP1)=-NP1
+*
+ CALL PLLEMK(N,NP2,EPS,IMPR,P,IROW,ICOL,IERR)
+ IF (IERR.GE.1) THEN
+ WRITE(6,1000) IERR
+ GO TO 500
+ ENDIF
+*
+ IF (IMPR.GE.3) THEN
+ WRITE(6,2000)
+ DO I=1,N,7
+ II=MIN0(I+6,N)
+ DO J=I,II
+ IF (IROW(J).LT.0) THEN
+ WRITE (ROW(J-I+1),'(1HX,I3.3)') (-IROW(J))
+ ELSE
+ WRITE (ROW(J-I+1),'(1HY,I3.3)') IROW(J)
+ ENDIF
+ ENDDO
+ WRITE(6,3000) (ROW(J-I+1),P(J,NP2),J=I,II)
+ ENDDO
+ ENDIF
+*
+ XOBJ(:N0)=BINF(:N0)
+ DO I=1,N
+ IR=-IROW(I)
+ IF ((IR.GT.0).AND.(IR.LE.N0)) THEN
+ XOBJ(IR)=BINF(IR)+P(I,NP2)
+ ENDIF
+ ENDDO
+ F=DOT_PRODUCT(COUT(:N0),XOBJ(:N0))
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ 500 DEALLOCATE(P)
+ DEALLOCATE(ICOL,IROW)
+ RETURN
+*
+ 1000 FORMAT(//,5X,'PLLINR: FAILURE OF THE LINEAR COMPLEMENTARITY SO',
+ > 'LUTION (IERR=',I5,').')
+ 2000 FORMAT(//,5X,'SOLUTION OF THE LINEAR COMPLEMENTARITY PROBLEM :',
+ > '*** X: KUHN-TUCKER MULTIPLIERS ;',5X,
+ > '*** Y: SLACK VARIABLES ',/)
+ 3000 FORMAT(7(1X,A4,'=',E12.5),/)
+ END
diff --git a/Utilib/src/PLPIVT.f b/Utilib/src/PLPIVT.f new file mode 100644 index 0000000..64d59f4 --- /dev/null +++ b/Utilib/src/PLPIVT.f @@ -0,0 +1,77 @@ +*DECK PLPIVT + SUBROUTINE PLPIVT(N,M,L,K,P,IROW,ICOL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Performs a pivot (L,K) on matrix P. +* PLPIVT = Linear Programming PIVoT +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* A. Hebert and T. Falcon +* +*Parameters: input +* N number of control variables. +* M number of constraints. +* L row index. +* K column index. +* P coefficient matrix. +* IROW permutation vector for row elements. +* ICOL permutation vector for column elements. +* +*Parameters: ouput +* P coefficient matrix. +* IROW permutation vector for row elements. +* ICOL permutation vector for column elements. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER M,N,L,K,IROW(N),ICOL(N+1) + DOUBLE PRECISION P(N,M) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION PVT + INTEGER I,J + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PLJ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PLJ(M)) +* + PVT = 1.0D0/P(L,K) + DO J=1,M + PLJ(J) = -PVT*P(L,J) + P(L,J) = PLJ(J) + ENDDO +* + DO I=1,N + IF(I.EQ.L) CYCLE + DO J=1,M + IF(J.EQ.K) CYCLE + P(I,J) = P(I,J) + PLJ(J)*P(I,K) + ENDDO + P(I,K) = PVT*P(I,K) + ENDDO +* + P(L,K) = PVT + I = IROW(L) + IROW(L) = ICOL(K) + ICOL(K) = I +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PLJ) + RETURN + END diff --git a/Utilib/src/PLQPRO.f b/Utilib/src/PLQPRO.f new file mode 100644 index 0000000..ed7958e --- /dev/null +++ b/Utilib/src/PLQPRO.f @@ -0,0 +1,160 @@ +*DECK PLQPRO
+ SUBROUTINE PLQPRO(N0,M1,MAXM,COUT,QUAD,APLUS,BPLUS,BINF,BSUP,XOBJ,
+ > F,EPS,IMPR,IERR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Minimizes a quadratic programming problem using LEMKE pivot.
+* PLQPRO=Quadratic PROgramming problem resolution.
+* The objective function is (1/2)X^T QUAD X + COUT^T X.
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s):
+* A. Hebert
+*
+*Parameters: input
+* N0 number of control variables.
+* M1 number of constraints.
+* MAXM first dimension of matrix APLUS.
+* COUT costs of control variables.
+* QUAD quadratic matrix for the objective function. QUAD is assumed
+* to be symmetric positive definite.
+* APLUS coefficient matrix for the linear constraints.
+* BPLUS right hand sides corresponding to the coefficient matrix.
+* BINF lower bounds of control variables.
+* BSUP upper bounds of control variables.
+* EPS tolerence used for pivoting.
+* IMPR print flag.
+*
+*Parameters: ouput
+* XOBJ control variables.
+* F objective function.
+* IERR return code (=0: normal completion).
+*
+*-----------------------------------------------------------------------
+*
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ INTEGER N0,M1,MAXM,IMPR,IERR
+ DOUBLE PRECISION BPLUS(M1),BINF(N0),BSUP(N0),XOBJ(N0),EPS,
+ > APLUS(MAXM,N0),COUT(N0),QUAD(N0,N0),F
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER N,NP1,NP2,I,J,II,IR
+ DOUBLE PRECISION XVAL
+ CHARACTER*4 ROW(7)
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IROW,ICOL
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: P
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(IROW(2*N0+M1),ICOL(2*N0+M1+1))
+ ALLOCATE(P(2*N0+M1,2*N0+M1+2))
+*----
+* CHECK SYMMETRY OF MATRIX QUAD.
+*----
+ DO I=1,N0
+ DO J=I+1,N0
+ IF(ABS(QUAD(I,J)-QUAD(J,I)).GT.EPS) THEN
+ IERR=10 ! matrix QUAD is not symmetric
+ WRITE(6,1000) IERR
+ GO TO 500
+ ENDIF
+ ENDDO
+ ENDDO
+*----
+* SET-UP AND SOLVE THE PARAMETRIC COMPLEMENTARITY PROBLEM.
+*----
+ N=2*N0+M1
+ NP1=N+1
+ NP2=N+2
+*
+ P(:N,:NP2)=0.0D0
+ DO I=1,N0
+ P(:N0,:N0)=QUAD(:N0,:N0)
+ XVAL=0.0D0
+ DO J=1,N0
+ XVAL=XVAL-QUAD(I,J)*BINF(J)
+ ENDDO
+ P(I,NP2)=COUT(I)-XVAL
+ P(N0+M1+I,NP2)=BSUP(I)-BINF(I)
+ P(I,N0+M1+I)=1.0D0
+ P(N0+M1+I,I)=-1.0D0
+ DO J=1,M1
+ P(I,N0+J)=APLUS(J,I)
+ ENDDO
+ ENDDO
+*
+ DO I=1,M1
+ XVAL=0.0D0
+ DO J=1,N0
+ XVAL=XVAL+APLUS(I,J)*BINF(J)
+ ENDDO
+ P(N0+I,NP2)=BPLUS(I)-XVAL
+ DO J=1,N0
+ P(N0+I,J)=-APLUS(I,J)
+ ENDDO
+ ENDDO
+*
+ DO I=1,N
+ IROW(I)= I
+ ICOL(I)=-I
+ P(I,NP1)=1.0D0
+ ENDDO
+ ICOL(NP1)=-NP1
+*
+ CALL PLLEMK(N,NP2,EPS,IMPR,P,IROW,ICOL,IERR)
+ IF (IERR.GE.1) THEN
+ WRITE(6,1000) IERR
+ GO TO 500
+ ENDIF
+*
+ IF(IMPR.GE.3) THEN
+ WRITE(6,2000)
+ DO I=1,N,7
+ II=MIN0(I+6,N)
+ DO J=I,II
+ IF (IROW(J).LT.0) THEN
+ WRITE (ROW(J-I+1),'(1HX,I3.3)') (-IROW(J))
+ ELSE
+ WRITE (ROW(J-I+1),'(1HY,I3.3)') IROW(J)
+ ENDIF
+ ENDDO
+ WRITE(6,3000) (ROW(J-I+1),P(J,NP2),J=I,II)
+ ENDDO
+ ENDIF
+*
+ XOBJ(:N0)=BINF(:N0)
+ DO I=1,N
+ IR=-IROW(I)
+ IF ((IR.GT.0).AND.(IR.LE.N0)) THEN
+ XOBJ(IR)=BINF(IR)+P(I,NP2)
+ ENDIF
+ ENDDO
+ F=DOT_PRODUCT(COUT(:N0),XOBJ(:N0))
+ XVAL=DOT_PRODUCT(MATMUL(QUAD(:N0,:N0),XOBJ(:N0)),XOBJ(:N0))
+ F=F+0.5*XVAL
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ 500 DEALLOCATE(P)
+ DEALLOCATE(ICOL,IROW)
+ RETURN
+*
+ 1000 FORMAT(//,5X,'PLQPRO: FAILURE OF THE LINEAR COMPLEMENTARITY SO',
+ > 'LUTION (IERR=',I5,').')
+ 2000 FORMAT(//,5X,'SOLUTION OF THE LINEAR COMPLEMENTARITY PROBLEM :',
+ > '*** X: KUHN-TUCKER MULTIPLIERS ;',5X,
+ > '*** Y: SLACK VARIABLES ',/)
+ 3000 FORMAT(7(1X,A4,'=',E12.5),/)
+ END
diff --git a/Utilib/src/PLSPLX.f b/Utilib/src/PLSPLX.f new file mode 100644 index 0000000..6956e62 --- /dev/null +++ b/Utilib/src/PLSPLX.f @@ -0,0 +1,499 @@ +*DECK PLSPLX
+ SUBROUTINE PLSPLX(N,M,MAXM,MINMAX,COUT,APLUS,B,INEGAL,BINF,BSUP,
+ > XOBJ,F,EPS,IMTHD,IMPR,IERR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Solves a linear programming problem using the revisited simplex
+* method.
+* PLSLPX = Linear Programming SimPLeX
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s):
+* A. Hebert and R. Chambon
+*
+*Parameters: input/ouput
+* N number of control variables.
+* M number of constraints.
+* MAXM first dimension of matrix APLUS.
+* MINMAX type of optimization (=-1: minimize; =1: maximize).
+* COUT costs of control variables.
+* APLUS coefficient matrix for the linear constraints.
+* B right hand sides corresponding to the coefficient matrix.
+* INEGAL constraint relations (=-1 for .GE.; =0 for .EQ.; =1 for .LE.).
+* BINF lower bounds of control variables.
+* BSUP upper bounds of control variables.
+* EPS tolerence used for SIMPLEX calculation.
+* IMTHD type of solution (=1: SIMPLEX/LEMKE; =3: MAP).
+* IMPR print flag.
+*
+*Parameters: ouput
+* XOBJ control variables.
+* F objective function.
+* IERR return code (=0: normal completion).
+*
+*-----------------------------------------------------------------------
+*
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ INTEGER N,M,MAXM,MINMAX,INEGAL(M),IMTHD,IMPR,IERR
+ DOUBLE PRECISION B(M+1),BINF(N),BSUP(N),XOBJ(N),EPS,COUT(N),
+ > APLUS(MAXM,N+M),F
+*----
+* LOCAL VARIABLES
+*----
+ DOUBLE PRECISION DUMY,DELTA,DELTAM,CSTE,XIJ,XIKI,BBAR,PM,QM
+ INTEGER I,J,MP1,MP2,IDIMC,JJ,IJK,J1,IPHASE,IND,K,IP,IQ,L,LL,
+ > LARTF
+ LOGICAL LARTIF
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IVARS
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: CRE,BORNE,XIK,BGAR,
+ > GSUP
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BASE0,AGAR
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(IVARS(M+2))
+ ALLOCATE(CRE(N+M),BORNE(N+M),XIK(M+2),BGAR(M+2),GSUP(N+M))
+ ALLOCATE(BASE0(M+2,M+2),AGAR(2,N+M))
+*
+ CRE(:N+M)=0.0D0
+ LARTIF = .FALSE.
+ IF(M.GT.MAXM) THEN
+ IERR = 9
+ GO TO 500
+ ENDIF
+ MP1 = M+1
+ MP2 = M+2
+*----
+* ORGANIZATION OF THE SIMPLEX TABLES
+*----
+ DO 3 I=1,M
+ DUMY = 0.0D0
+ DO 1 J=1,N
+ DUMY = DUMY + APLUS(I,J)*BINF(J)
+ 1 CONTINUE
+*
+ BGAR(I) = B(I)-DUMY
+ IF(BGAR(I).GE.0.0) GOTO 3
+ DO 2 J=1,N
+ APLUS(I,J) = -APLUS(I,J)
+ 2 CONTINUE
+*
+ BGAR(I) = -BGAR(I)
+ B(I) = -B(I)
+ INEGAL(I) = -INEGAL(I)
+ 3 CONTINUE
+*
+ CSTE = 0.0D0
+ DO 4 J=1,N
+ CSTE = CSTE + COUT(J)*BINF(J)
+ GSUP(J) = BSUP(J) - BINF(J)
+ AGAR(1,J) = REAL(MINMAX)*COUT(J)
+ 4 CONTINUE
+*
+ DO 8 J=1,N
+ AGAR(2,J) = 0.0D0
+ DO 7 I=1,M
+ AGAR(2,J) = AGAR(2,J) - APLUS(I,J)
+ 7 CONTINUE
+ 8 CONTINUE
+*
+ BGAR(MP1) = 0.0
+ BGAR(MP2) = 0.0
+*
+ DO 9 I=1,M
+ BGAR(MP2) = BGAR(MP2) - BGAR(I)
+ 9 CONTINUE
+*----
+* SLACK VARIABLES
+*----
+ IDIMC = N
+ DO 13 I=1,M
+ IF(INEGAL(I).EQ.0) GOTO 13
+ IDIMC = IDIMC + 1
+ GSUP(IDIMC) = 1.0E+25
+ DO 12 J=1,M
+ APLUS(J,IDIMC) = 0.0D0
+ 12 CONTINUE
+*
+ APLUS(I,IDIMC) = REAL(INEGAL(I))
+ AGAR(1,IDIMC) = 0.0D0
+ AGAR(2,IDIMC) = -REAL(INEGAL(I))
+ 13 CONTINUE
+*
+ DO 15 I=1,MP2
+ IVARS(I) = IDIMC + I
+ DO 14 J=1,MP2
+ BASE0(I,J) = 0.0D0
+ 14 CONTINUE
+ BASE0(I,I) = 1.0D0
+ 15 CONTINUE
+*
+ IF(IMPR.GE.6) THEN
+ WRITE (6,800)
+ WRITE (6,840) N,M,IDIMC
+ DO 510 J=1,N+M,12
+ JJ = MIN0(J+11,N+M)
+ WRITE (6,841) (J1,J1=J,JJ)
+ DO 505 I=1,M
+ WRITE (6,805) I,(APLUS(I,J1),J1=J,JJ)
+ 505 CONTINUE
+ IF(JJ.NE.N+M) WRITE (6,803)
+ 510 CONTINUE
+*
+ WRITE (6,810) (I,COUT(I),I=1,N)
+ WRITE (6,820) (I,BGAR(I),I=1,MP2)
+ WRITE (6,830) (I,INEGAL(I),I=1,M)
+ WRITE (6,835) (I,GSUP(I),I=1,IDIMC)
+ ENDIF
+*----
+* END OF PHASE 1 IF BGAR(M+2)=0 +- EPS
+*----
+ IERR = 0
+ IND=0
+ LARTF=0
+ DO 11 I=1,IDIMC
+ IF(GSUP(I).EQ.0.0) GSUP(I)=1.0E-6
+ BORNE(I)=0.0
+ 11 CONTINUE
+*
+ IPHASE = 1
+*
+ 10 IF((IPHASE.EQ.2) .AND. (.NOT.LARTIF)) GOTO 21
+ IF((ABS(BGAR(MP2)).LT.EPS) .OR. (LARTIF)) THEN
+ IPHASE=2
+ LARTIF=.FALSE.
+ IJK=1
+ 99 IF(.NOT.((IJK.GT.IDIMC) .OR. (LARTIF))) THEN
+ IF(IVARS(IJK).GT.IDIMC) THEN
+ LARTIF=.TRUE.
+ LARTF=IJK
+ ENDIF
+ IJK=IJK+1
+ GOTO 99
+ ENDIF
+ ENDIF
+*----
+* RETURN IF NO BASE SWITCH HAS BEEN DONE
+*----
+ 20 IND=MP2
+ 21 IF(IPHASE.EQ.2) IND=MP2-1
+ IF(IMPR.GE.6) THEN
+ WRITE (6,845) IPHASE
+ WRITE (6,843)
+ WRITE (6,850)
+ DO 520 J=1,MP2,12
+ JJ=MIN0(J+11,MP2)
+ WRITE (6,841) (J1,J1=J,JJ)
+ DO 515 I=1,MP2
+ WRITE (6,805) I,(BASE0(I,J1),J1=J,JJ)
+ 515 CONTINUE
+ IF(JJ.NE.MP2) WRITE (6,803)
+ 520 CONTINUE
+ WRITE (6,820) (I,BGAR(I),I=1,MP2)
+ WRITE (6,855) (I,IVARS(I),I=1,MP2)
+ WRITE (6,860) (I,BORNE(I),I=1,IDIMC)
+ ENDIF
+*----
+* SELECTION OF THE BASE K VECTOR TO PICK IN
+*----
+ K=0
+ DELTAM=0.0D0
+ DO 100 J=1,IDIMC
+ DELTA=0.0D0
+ DO 30 JJ=1,MP2
+ IF(IVARS(JJ).EQ.J) GOTO 90
+ 30 CONTINUE
+ DELTA=BASE0(IND,MP1)*AGAR(1,J)+BASE0(IND,MP2)*AGAR(2,J)
+ DO 35 I=1,M
+ DELTA=DELTA+BASE0(IND,I)*APLUS(I,J)
+ 35 CONTINUE
+ IF(IMPR.GE.7) WRITE (6,865) J,DELTA
+*
+ IF(BORNE(J).EQ.GSUP(J)) GOTO 45
+ IF(DELTA.GE.0.0) GOTO 90
+ IF(K.EQ.0) GOTO 40
+ 39 IF(DELTA.GE.DELTAM) GOTO 90
+ 40 K=J
+ DELTAM=DELTA
+ GOTO 90
+ 45 IF(DELTA.LE.0.0) GOTO 90
+ DELTA=-DELTA
+ IF(K.EQ.0) GOTO 40
+ IF(K.GT.0) GOTO 39
+*
+ 90 CRE(J)=DELTA
+ 100 CONTINUE
+*
+ IF(IMPR.GE.7) THEN
+ WRITE (6,870) (I,CRE(I),I=1,N+M)
+ WRITE (6,875) K
+ ENDIF
+*
+ IF(K.NE.0) GOTO 125
+ DO 105 JJ=1,M
+ IF(IVARS(JJ).GT.IDIMC) GOTO 110
+ 105 CONTINUE
+ IF(IPHASE.EQ.2) GOTO 115
+ IERR=1
+ GO TO 500
+ 110 IF(IPHASE.EQ.2) GOTO 115
+ IF(IMTHD.EQ.1) THEN
+* no solution.
+ IERR=2
+ GO TO 500
+ ELSEIF(IMTHD.EQ.3) THEN
+* no feasible solution in the reduced domain. Go to PHASE 2 with
+* modified constraints.
+ IERR=2
+ GO TO 115
+ ENDIF
+*
+ 115 DO 999 I=1,MP2
+ DO 950 J=1,IDIMC
+ XIJ=0.0D0
+ DO 920 JJ=1,M
+ IF(J.EQ.IVARS(JJ)) GOTO 950
+ 920 CONTINUE
+ IF(BORNE(J).NE.GSUP(J)) GOTO 950
+ XIJ=BASE0(I,MP1)*AGAR(1,J)+BASE0(I,MP2)*AGAR(2,J)
+ DO 925 JJ=1,M
+ XIJ=XIJ+BASE0(I,JJ)*APLUS(JJ,J)
+ 925 CONTINUE
+ BGAR(I)=BGAR(I)-XIJ*GSUP(J)
+ 950 CONTINUE
+ 999 CONTINUE
+ DO 400 I=1,N
+ DO 390 J=1,M
+ IF(IVARS(J).NE.I) GO TO 390
+ XOBJ(I)=BINF(I)+BGAR(J)
+ GO TO 400
+ 390 CONTINUE
+ XOBJ(I)=BINF(I)+BORNE(I)
+ 400 CONTINUE
+ DO 410 I=1,IDIMC
+ CRE(I)=CRE(I)*REAL(MINMAX)
+ 410 CONTINUE
+ F=REAL(-MINMAX)*BGAR(MP1)+CSTE
+ IF(IMPR.GE.5) THEN
+ WRITE (6,890) F,(I,XOBJ(I),I=1,N)
+ WRITE (6,820) (I,BGAR(I),I=1,MP2)
+ WRITE (6,855) (I,IVARS(I),I=1,MP2)
+ WRITE (6,860) (I,BORNE(I),I=1,IDIMC)
+ ENDIF
+ GO TO 500
+*----
+* SELECTION OF THE VECTOR TO PICK OUT
+*----
+ 125 IF(IMPR.GE.7) WRITE (6,880)
+ IP=0
+ IQ=0
+*
+ IF(K.GT.N+M) THEN
+ WRITE(6,'(1X,A)') 'PLSPLX: AGAR OVERFLOW.'
+ IERR=10
+ GO TO 500
+ ENDIF
+ DO 200 I=1,M
+*
+ BBAR=0.0D0
+ DO 150 J=1,IDIMC
+ IF(BORNE(K).EQ.GSUP(K) .AND. J.EQ.K) GOTO 150
+ DO 130 JJ=1,M
+ IF(J.EQ.IVARS(JJ)) GOTO 150
+ 130 CONTINUE
+ IF(BORNE(J).NE.GSUP(J)) GOTO 150
+ XIJ=BASE0(I,MP1)*AGAR(1,J)+BASE0(I,MP2)*AGAR(2,J)
+ DO 135 JJ=1,M
+ XIJ=XIJ+BASE0(I,JJ)*APLUS(JJ,J)
+ 135 CONTINUE
+ BBAR=BBAR-GSUP(J)*XIJ
+ IF(IMPR.GE.7) THEN
+ WRITE (6,885) I,J,XIJ,BBAR
+ ENDIF
+ 150 CONTINUE
+ BBAR=BBAR+BGAR(I)
+ XIKI=BASE0(I,MP1)*AGAR(1,K)+BASE0(I,MP2)*AGAR(2,K)
+ DO 155 JJ=1,M
+ XIKI=XIKI+BASE0(I,JJ)*APLUS(JJ,K)
+ 155 CONTINUE
+ XIK(I)=XIKI
+*----
+* CASE I: XOBJ(K)=0.0
+*----
+ IF(BORNE(K).EQ.GSUP(K)) GOTO 175
+ IF(ABS(XIKI).LT.EPS) GOTO 200
+ IF(XIKI.GT.0.0) GOTO 165
+ IF(LARTIF.AND.I.EQ.LARTF) GOTO 165
+*----
+* TEST FOR ARTIFICIAL VARIABLES
+*----
+ IF(IVARS(I).GT.IDIMC) GOTO 200
+ IF(IQ.EQ.0) GOTO 160
+ IF(QM.LE.((GSUP(IVARS(I))-BBAR)/(-XIKI))) GOTO 200
+ 160 CONTINUE
+ IQ=I
+ QM=(GSUP(IVARS(I))-BBAR)/(-XIKI)
+ GOTO 200
+ 165 CONTINUE
+ IF(IP.EQ.0) GOTO 170
+ IF(PM.LE.(BBAR/XIKI)) GOTO 200
+ 170 IP=I
+ PM=BBAR/XIKI
+ GOTO 200
+*----
+* CASE II: XOBJ(K) = UPPER BOUND
+*----
+ 175 IF(ABS(XIKI).LT.EPS) GOTO 200
+ IF(XIKI.GT.0.0) GOTO 185
+ IF(IQ.EQ.0) GOTO 180
+ IF(QM.GE.(BBAR/XIKI)) GOTO 200
+ 180 IQ=I
+ QM=BBAR/XIKI
+ GOTO 200
+*----
+* TEST FOR ARTIFICIAL VARIABLES
+*----
+ 185 IF(IVARS(I).GT.IDIMC) GOTO 200
+ IF(IP.EQ.0) GOTO 190
+ IF(PM.GE.((BBAR-GSUP(IVARS(I)))/XIKI)) GOTO 200
+ 190 IP=I
+ PM=(BBAR-GSUP(IVARS(I)))/XIKI
+ 200 CONTINUE
+*
+ IF(IMPR.GE.7) WRITE (6,894) IQ,QM,IP,PM
+*
+ XIK(MP1)=BASE0(MP1,MP1)*AGAR(1,K)+BASE0(MP1,MP2)*AGAR(2,K)
+ XIK(MP2)=BASE0(MP2,MP1)*AGAR(1,K)+BASE0(MP2,MP2)*AGAR(2,K)
+ DO 204 JJ=1,M
+ XIK(MP1)=XIK(MP1)+BASE0(MP1,JJ)*APLUS(JJ,K)
+ XIK(MP2)=XIK(MP2)+BASE0(MP2,JJ)*APLUS(JJ,K)
+ 204 CONTINUE
+*
+ IF(BORNE(K).EQ.GSUP(K)) GOTO 250
+ IF(IP.EQ.0) GOTO 205
+ IF(IQ.EQ.0) GOTO 220
+ IF(QM.LE.PM) GOTO 210
+ GOTO 220
+ 205 IF(IQ.EQ.0) GOTO 211
+ 210 IF(QM.LE.GSUP(K)) GOTO 215
+ 211 BORNE(K)=GSUP(K)
+ GOTO 20
+ 215 L=IQ
+ LL=IVARS(L)
+ IF(LL.LE.IDIMC) BORNE(LL)=GSUP(LL)
+ IVARS(L)=K
+ IF(IMPR.GE.7) WRITE (6,895) L,LL,IVARS(L)
+ GOTO 300
+ 220 IF(PM.GT.GSUP(K)) GOTO 211
+ L=IP
+ LL=IVARS(L)
+ IF(LL.LE.IDIMC) BORNE(LL)=0.0
+ IVARS(L)=K
+ IF(IMPR.GE.7) WRITE (6,895) L,LL,IVARS(L)
+ GOTO 300
+*
+ 250 IF(IP.EQ.0) GOTO 255
+ IF(IQ.EQ.0) GOTO 265
+ IF(QM.GE.PM) GOTO 256
+ GOTO 265
+ 255 IF(IQ.EQ.0) GOTO 257
+ 256 IF(QM.GE.0.0) GOTO 260
+ 257 BORNE(K)=0.0
+ GOTO 20
+ 260 L=IQ
+ LL=IVARS(L)
+ IF(LL.LE.IDIMC) BORNE(LL)=0.0
+ IVARS(L)=K
+ IF(IMPR.GE.7) WRITE (6,895) L,LL,IVARS(L)
+ GOTO 300
+ 265 IF(PM.LE.0.0) GOTO 257
+ L=IP
+ LL=IVARS(L)
+ IF(LL.LE.IDIMC) BORNE(LL)=GSUP(LL)
+ IVARS(L)=K
+ IF(IMPR.GE.7) WRITE (6,895) L,LL,IVARS(L)
+*
+* PIVOTAGE SUR XIK
+ 300 IF(IMPR.GE.7) WRITE (6,905) L,XIK(L)
+ DO 325 I=1,MP2
+ IF(I.EQ.L) GOTO 325
+ BGAR(I)=BGAR(I)-BGAR(L)/XIK(L)*XIK(I)
+ 325 CONTINUE
+ BGAR(L)=BGAR(L)/XIK(L)
+*
+ DO 375 I=1,MP2
+ IF(I.EQ.L) GOTO 375
+ DO 335 J=1,MP2
+ BASE0(I,J)=BASE0(I,J)-(BASE0(L,J)/XIK(L))*XIK(I)
+ 335 CONTINUE
+ 375 CONTINUE
+ DO 380 J=1,MP2
+ BASE0(L,J)=BASE0(L,J)/XIK(L)
+ 380 CONTINUE
+*
+ GOTO 10
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ 500 DEALLOCATE(AGAR,BASE0)
+ DEALLOCATE(GSUP,BGAR,XIK,BORNE,CRE)
+ DEALLOCATE(IVARS)
+ RETURN
+*
+* .................................................................
+* ...
+* ... F O R M A T S
+* ...
+* .................................................................
+*
+ 800 FORMAT (///25X,35H- - - - SIMPLEX ALGORITHM - - -)
+ 803 FORMAT (//10X,8HCONTN.../)
+ 805 FORMAT (1X,I4,1P,12E10.2)
+ 810 FORMAT (//10X,28H+ + + + + TABLE COUT(N) :/
+ 1 3(/6(1X,5HCOUT(,I4,4H) = ,1P,E10.3,:)))
+ 820 FORMAT (//10X,30H+ + + + + TABLE BGAR(M+2) :/
+ 1 3(/6(1X,5HBGAR(,I4,4H) = ,1P,E10.3,:)))
+ 830 FORMAT (//10X,30H+ + + + + TABLE INEGAL(M) :/
+ 1 3(/6(1X,5HINEG(,I4,4H) = ,I4,:)))
+ 835 FORMAT (//10X,32H+ + + + + TABLE GSUP(IDIMC) :/
+ 1 5(/6(1X,5HGSUP(,I4,4H) = ,1P,E10.3,:)))
+ 840 FORMAT (//34H-- NUMBER OF CONTROL VARIABLES (N):,I4/
+ 1 10X,29H-- NOMBER OF CONSTRAINTS (M):,I4/
+ 2 10X,38H-- NUMBER OF SLACK VARIABLES (IDIMC) :,I4//10X,
+ 3 32H+ + + + + TABLE APLUS(M,N+M) :/)
+ 841 FORMAT (1X,12I10)
+ 843 FORMAT (/10X,34H-- SELECTION OF VECTOR TO PICK IN.)
+ 845 FORMAT (///25X,42H- - - - - START OF ITERATION - - - - -//
+ 1 10X,17H-- PHASE NUMBER :,I4/)
+ 850 FORMAT (//10X,34H+ + + + + TABLE BASE0(M+2,M+2) : /)
+ 855 FORMAT (//10X,31H+ + + + + TABLE IVARS(M+2) :/
+ 1 2(/6(1X,5HIVAR(,I4,3H) =,I5,:)))
+ 860 FORMAT (//10X,33H+ + + + + TABLE BORNE(IDIMC) :/
+ 1 5(/6(1X,5HBORN(,I4,3H) =,1P,E11.3,:)))
+ 865 FORMAT (/10X,21H-- CANDIDATE VECTOR :,I4,2X,7HVALUE :,1P,E10.3)
+ 870 FORMAT (//10X,29H+ + + + + TABLE CRE(N+M) :/
+ 1 3(/6(1X,4HCRE(,I4,3H) =,1P,E11.3,:)))
+ 875 FORMAT (/10X,19H-- SELECTED PIVOT :,I4)
+ 880 FORMAT (/10X,35H-- SELECTION OF VECTOR TO PICK OUT.)
+ 885 FORMAT(//10X,3HI =,I4,5X,3HJ =,I4,5X,5HXIJ =,1P,E11.3,5X,
+ 1 6HBBAR =,E11.3)
+ 890 FORMAT (//10X,28HOPTIMAL OBJECTIVE FUNCTION =,1P,E12.4//10X,
+ 1 28H+ + + + + TABLE XOBJ(N) :/5(/6(1X,5HXOBJ(,I4,3H) =,1P,
+ 2 E11.3,:)))
+ 894 FORMAT (10X,27H-- SELECTED VARIABLES ATE :/15X,4HIQ =,I4,5X,
+ 1 4HQM =,1P,E11.3,10X,4HIP =,I4,5X,4HPM =,E11.3)
+ 895 FORMAT (10X,3HL =,I4,5X,4HLL =,I4,5X,10HIVARS(L) =,I5)
+ 905 FORMAT (10X,25H-- START OF PIVOTING; L =,I4,5X,8HXIK(L) =,
+ 1 1P,E11.3)
+ END
diff --git a/Utilib/src/PRINAM.f b/Utilib/src/PRINAM.f new file mode 100644 index 0000000..b3a57fa --- /dev/null +++ b/Utilib/src/PRINAM.f @@ -0,0 +1,63 @@ +*DECK PRINAM + SUBROUTINE PRINAM(T,A,N) +* +*----------------------------------------------------------------------- +* +* PRINT A REAL, INTEGER OR DOUBLE PRECISION ARRAY. +* +* INPUT PARAMETER: +* T : CHARACTER*6 NAME OF THE ARRAY. +* A : REAL ARRAY TO PRINT. DIMENSION A(N) +* IA : INTEGER ARRAY TO PRINT. DIMENSION IA(N) +* DA : DOUBLE PRECISION ARRAY TO PRINT. DIMENSION DA(N) +* +*----------------------------------------------------------------------- +* + CHARACTER*6 T + INTEGER N + REAL A(N) + PARAMETER (MAX5=5,MAX10=10,IOUT=6) +* + MN=MIN0(N,MAX5) + WRITE (IOUT,10) T,(A(I),I=1,MN) + 10 FORMAT(1X,20('-')/1X,A6,1X,1P,5E13.6) + IF(N.LT.MAX5) GOTO 30 + MN=MN+1 + WRITE (IOUT,20) (A(I),I=MN,N) + 20 FORMAT(8X,1P,5E13.6) + 30 CONTINUE + RETURN + END SUBROUTINE PRINAM +C ------------------ P R I N I M + SUBROUTINE PRINIM(T,IA,N) + CHARACTER*6 T + INTEGER N,IA(N) + PARAMETER (MAX5=5,MAX10=10,IOUT=6) +* + MN=MIN0(N,MAX10) + WRITE (IOUT,40) T,(IA(I),I=1,MN) + 40 FORMAT(1X,20('-')/1X,A6,1X,10I6) + IF(N.LT.MAX10) GOTO 60 + MN=MN+1 + WRITE (IOUT,50) (IA(I),I=MN,N) + 50 FORMAT(8X,10I6) + 60 CONTINUE + RETURN + END SUBROUTINE PRINIM +C ------------------ P R I N D M + SUBROUTINE PRINDM(T,DA,N) + CHARACTER*6 T + INTEGER N + DOUBLE PRECISION DA(N) + PARAMETER (MAX5=5,MAX10=10,IOUT=6) +* + MN=MIN0(N,MAX5) + WRITE (IOUT,70) T,(DA(I),I=1,MN) + 70 FORMAT(1X,20('-')/1X,A6,1X,1P,5D13.6) + IF(N.LT.MAX5) GOTO 90 + MN=MN+1 + WRITE (IOUT,80) (DA(I),I=MN,N) + 80 FORMAT(8X,1P,5D13.6) + 90 CONTINUE + RETURN + END SUBROUTINE PRINDM diff --git a/Utilib/src/PSCPUT.f b/Utilib/src/PSCPUT.f new file mode 100644 index 0000000..4fe7220 --- /dev/null +++ b/Utilib/src/PSCPUT.f @@ -0,0 +1,94 @@ +*DECK PSCPUT + SUBROUTINE PSCPUT(ISPSP,CMDSTR) +C +C--------------------------- PSCPUT --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSCPUT +C USE : TRANSFER COMMAND LINE TO FILE +C REPLACES PSPLOT ROUTINE FILLER +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C CMDSTR : COMMAND LINE C*132 +C LOCAL +C IBSL : ASCII REPRESENTATION OF BACKSLASH I +C +C--------------------------- PSCPUT -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + CHARACTER CMDSTR*132 +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + INTEGER IBSL + PARAMETER (IBSL=92,NAMSBR='PSCPUT') + INTEGER LCMD,IBSLH,ISPACE,IPAREN,IC + CHARACTER CBSL*1 + CBSL=CHAR(IBSL) + LCMD=0 + IBSLH=0 + ISPACE=0 + IPAREN=0 +C---- +C COMPRESS COMMAND LINE TO REMOVE USELESS BLANKS +C---- + DO 100 IC=1,132 + IF(CMDSTR(IC:IC) .EQ. ' ' ) THEN +C---- +C REMOVE BLANK IF NOT INSERTED BETWEEN () OR +C 2 OR MORE IN SUCCESSION +C---- + IF(IPAREN .EQ. 0) THEN + ISPACE=ISPACE+1 + ENDIF + IF(ISPACE .LE. 1 ) THEN + LCMD=LCMD+1 + CMDSTR(LCMD:LCMD)=CMDSTR(IC:IC) + ENDIF + ELSE + ISPACE=0 + LCMD=LCMD+1 + CMDSTR(LCMD:LCMD)=CMDSTR(IC:IC) +C---- +C TEST FOR SET OF PARENTHESIS +C "Backslash"( AND "Backslash") ARE CONSIDERED AS COMMENTED PARENTHESIS +C AND NOT TREATED +C---- + IF(IBSLH .EQ. 0) THEN + IF(CMDSTR(IC:IC) .EQ. '(') THEN + IPAREN=IPAREN+1 + ELSE IF(CMDSTR(IC:IC) .EQ. ')') THEN + IPAREN=IPAREN-1 + ENDIF + ENDIF + IBSLH=0 + IF(CMDSTR(IC:IC) .EQ. CBSL) THEN + IBSLH=1 + ENDIF + ENDIF + 100 CONTINUE +C---- +C TEST IF LAST CHARACTER IS A BLANK +C---- + IF(CMDSTR(LCMD:LCMD).EQ. ' ') THEN + LCMD=LCMD-1 + ENDIF +C---- +C CLEAR REST OF COMMAND STRING AFTER COMPRESSION +C OF BLANK CHARACTERS +C---- + IF(LCMD .LT. 132) THEN + CMDSTR(LCMD+1:132)=' ' + ENDIF +C---- +C TRANSFER COMPRESSED COMMAND LINE TO FILE +C---- + IF(LCMD .GT. 0) THEN + WRITE(ISPSP,'(132A1)')(CMDSTR(IC:IC),IC=1,LCMD) + ENDIF + RETURN + END diff --git a/Utilib/src/PSCUTP.f b/Utilib/src/PSCUTP.f new file mode 100644 index 0000000..907becf --- /dev/null +++ b/Utilib/src/PSCUTP.f @@ -0,0 +1,27 @@ +*DECK PSCUTP + SUBROUTINE PSCUTP(ISPSP) +C +C--------------------------- PSCUTP --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSCUTP +C USE : CUT POSTSCRIPT PAGE +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C +C--------------------------- PSCUTP -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='PSCUTP') + CHARACTER CMDSTR*132 + CMDSTR='stroke showpage' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSDCIR.f b/Utilib/src/PSDCIR.f new file mode 100644 index 0000000..084a82f --- /dev/null +++ b/Utilib/src/PSDCIR.f @@ -0,0 +1,36 @@ +*DECK PSDCIR + SUBROUTINE PSDCIR(ISPSP,XYCENT,RADIUS) +C +C--------------------------- PSDCIR --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSDCIR +C USE : DRAW CIRCLE +C REPLACES PSPLOT ROUTINE CIRCLE +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C YXCENT : POSITION (X,Y) OF LINE INTERSECTION R(2) +C RADIUS : ARC RADIUS R +C +C--------------------------- PSDCIR -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + REAL XYCENT(2),RADIUS +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSDCIR',CONVER=72.0) + CHARACTER CMDSTR*132 + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(3(F8.2,1X),A2)') + > XYCENT(1)*CONVER,XYCENT(2)*CONVER,RADIUS*CONVER,'C ' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSDRAI.f b/Utilib/src/PSDRAI.f new file mode 100644 index 0000000..db6187e --- /dev/null +++ b/Utilib/src/PSDRAI.f @@ -0,0 +1,102 @@ +*DECK PSDRAI + SUBROUTINE PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG) +C +C------------------------- PSDRAI ------------------------------- +C +C 1- SUBROUTINE STATISTICS: +C NAME : PSDRAI +C USE : DRAW RECTANGULAR/ANNULAR INTERSECTION REGION +C +C 2- PARAMETERS: +C INPUT +C ISPSP : POSTSCRIPT STRUCTURE I +C NSEG : NUMBER OF REGION INTERSECTION I +C NUMBER OF SEGMENTS IS NSEG-1 +C IORDER : TYPE OF REGION R(NSEG) +C = -2 : ARC SEGMENT BEGINS +C = -1 : ARC SEGMENT ENDS +C = 0 : CLOSE PATH +C > 0 : CORNER +C CENTER : X AND Y POSITION OF ANNULUS CENTER R(2) +C RADANG : SEGMENTS INTERSECTION POINTS R(2,NSEG) +C WITH RESPECT TO ANNULAR REGION CENTER +C RADANG(1) = RADIAL POSITION +C RADANG(2) = ANGULAR POSITION +C +C---------------------------------------------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NSEG + INTEGER IORDER(NSEG) + REAL CENTER(2),RADANG(2,NSEG) +C---- +C LOCAL PARAMETERS +C---- + REAL CONVER,PI + CHARACTER NAMSBR*6 + PARAMETER (CONVER=72.0,PI=3.1415926535897932, + > NAMSBR='PSDRAI') + CHARACTER CMDSTR*132 + INTEGER IPT,IDEP,IFIN + REAL XYDEP(2),ANGL(2),XYFIN(2) +C---- +C POSITION REFERENCE POINT AT CENTER OF ANNULAR REGION +C---- + XYDEP(1)=CENTER(1) + XYDEP(2)=CENTER(2) +* CALL PSMOVE(ISPSP,XYDEP,-3) +C---- +C MOVE TO FIRST POINT +C---- + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + IDEP=IORDER(1) + XYDEP(1)=RADANG(1,1)*COS(RADANG(2,1)) + XYDEP(2)=RADANG(1,1)*SIN(RADANG(2,1)) + ANGL(1)=180.0*RADANG(2,1)/PI + IF(IDEP .EQ. -1 .OR. IDEP .GT. 0) THEN + CALL PSMOVE(ISPSP,XYDEP,3) + ENDIF +C---- +C SCAN SEGMENTS +C---- + DO 100 IPT=2,NSEG + CMDSTR=' ' + IFIN=IORDER(IPT) + XYFIN(1)=RADANG(1,IPT)*COS(RADANG(2,IPT)) + XYFIN(2)=RADANG(1,IPT)*SIN(RADANG(2,IPT)) + IF (IDEP .EQ. -2) THEN +C---- +C ARC SEGMENT +C FIND ANGLES ASSOCIATED WITH ARC +C---- + ANGL(2)=180.0*RADANG(2,IPT)/PI + IF(ANGL(2) .LT. ANGL(1)) THEN + ANGL(2)=ANGL(2)+360.0 + ENDIF + WRITE(CMDSTR,'(5(F8.2,1X),A3)') + > 0.0,0.0,RADANG(1,IPT)*CONVER,ANGL(1),ANGL(2),'arc' + CALL PSCPUT(ISPSP,CMDSTR) + ELSE +C---- +C LINE +C---- + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYFIN(1)*CONVER,XYFIN(2)*CONVER,'L' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + IDEP=IFIN + XYDEP(1)=XYFIN(1) + XYDEP(2)=XYFIN(2) + ANGL(1)=180.0*RADANG(2,IPT)/PI + 100 CONTINUE +C---- +C RESET REFERENCE POINT AT ORIGINAL POSITION +C---- + CMDSTR='closepath' + CALL PSCPUT(ISPSP,CMDSTR) + XYDEP(1)=-CENTER(1) + XYDEP(2)=-CENTER(2) +* CALL PSMOVE(ISPSP,XYDEP,-3) + RETURN + END diff --git a/Utilib/src/PSDREG.f b/Utilib/src/PSDREG.f new file mode 100644 index 0000000..02ce3c5 --- /dev/null +++ b/Utilib/src/PSDREG.f @@ -0,0 +1,45 @@ +*DECK PSDREG + SUBROUTINE PSDREG(ISPSP,NPTS,XYPTS) +C +C--------------------------- PSDREG --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSDREG +C USE : DRAW REGION +C REPLACES PSPLOT ROUTINE FILRGNC +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C NPTS : NUMBER OF POINTS I +C YXPTS : POSITION (X,Y) OF LINE INTERSECTION R(2,NPTS) +C +C--------------------------- PSDREG -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NPTS + REAL XYPTS(2,NPTS) +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSDREG',CONVER=72.0) + INTEGER IPT + CHARACTER CMDSTR*132 + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYPTS(1,1)*CONVER,XYPTS(2,1)*CONVER,'M' + CALL PSCPUT(ISPSP,CMDSTR) + DO 100 IPT=2,NPTS + CMDSTR=' ' + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYPTS(1,IPT)*CONVER,XYPTS(2,IPT)*CONVER,'L' + CALL PSCPUT(ISPSP,CMDSTR) + 100 CONTINUE + CMDSTR='closepath' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSFARC.f b/Utilib/src/PSFARC.f new file mode 100644 index 0000000..568a536 --- /dev/null +++ b/Utilib/src/PSFARC.f @@ -0,0 +1,40 @@ +*DECK PSFARC + SUBROUTINE PSFARC(ISPSP,XYCENT,RADIUS,ANGR) +C +C--------------------------- PSFARC --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSFARC +C USE : FILL ARC +C REPLACES PSPLOT ROUTINE ARC +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C YXCENT : POSITION (X,Y) OF LINE INTERSECTION R(2) +C RADIUS : ARC RADIUS R +C ANGR : ARC ANGLE RANGE R(2) +C +C--------------------------- PSFARC -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + REAL XYCENT(2),RADIUS,ANGR(2) +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSFARC',CONVER=72.0) + CHARACTER CMDSTR*132 + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(5(F8.2,1X),A3)') + > XYCENT(1)*CONVER,XYCENT(2)*CONVER,RADIUS*CONVER, + > ANGR(1),ANGR(2),'arc' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='cf' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSFCIR.f b/Utilib/src/PSFCIR.f new file mode 100644 index 0000000..5b79f13 --- /dev/null +++ b/Utilib/src/PSFCIR.f @@ -0,0 +1,36 @@ +*DECK PSFCIR + SUBROUTINE PSFCIR(ISPSP,XYCENT,RADIUS) +C +C--------------------------- PSFCIR --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSFCIR +C USE : FILL CIRCLE +C REPLACES PSPLOT ROUTINE CIRCLE +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C YXCENT : POSITION (X,Y) OF LINE INTERSECTION R(2) +C RADIUS : ARC RADIUS R +C +C--------------------------- PSFCIR -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + REAL XYCENT(2),RADIUS +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSFCIR',CONVER=72.0) + CHARACTER CMDSTR*132 + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(3(F8.2,1X),A8)') + > XYCENT(1)*CONVER,XYCENT(2)*CONVER,RADIUS*CONVER,'C fill ' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSFILL.f b/Utilib/src/PSFILL.f new file mode 100644 index 0000000..60eed97 --- /dev/null +++ b/Utilib/src/PSFILL.f @@ -0,0 +1,78 @@ +*DECK PSFILL + SUBROUTINE PSFILL(ISPSP,IFILL,GRYCOL,KFS,KFR) +C +C--------------------------- PSFILL --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSFILL +C USE : SET GRAY LEVEL OR COLOR AND FILL PATERN +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C IFILL : FILL TYPE I +C = 0 SET TO COLOR(4) +C = 1 SET TO GRAY LEVEL +C = 2 SET RGB COLLOR PATTERN +C = 3 SET GRYCOL COLLOR PATTERN +C = 4 SET HSB COLLOR PATTERN +C GRYCOL : GRAY LEVEL OF COLOR INTENSITY R(4) +C KFS : FLAG TO SAVE DRAWING BEFORE FILLING I +C = 0 : NO SAVE +C = 1 : SAVE +C KFR : FLAG TO RESTORE DRAWING BEFORE FILLING I +C = 0 : NO RESTORE +C = 1 : RESTORE +C +C--------------------------- PSFILL -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,IFILL + REAL GRYCOL(4) + INTEGER KFS,KFR +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='PSFILL') + REAL COLOR(4) + CHARACTER CMDSTR*132 +C---- +C TAKE COLOR LEVEL BETWEEN 0.0 AND 1.0 +C---- + IF(KFR .EQ. 1) THEN + CMDSTR='grestore' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + IF(KFS .EQ. 1) THEN + CMDSTR='gsave' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + COLOR(1)=MIN(1.0,ABS(GRYCOL(1))) + COLOR(2)=MIN(1.0,ABS(GRYCOL(2))) + COLOR(3)=MIN(1.0,ABS(GRYCOL(3))) + COLOR(4)=MIN(1.0,ABS(GRYCOL(4))) + COLOR(1)=MAX(0.0,COLOR(1)) + COLOR(2)=MAX(0.0,COLOR(2)) + COLOR(3)=MAX(0.0,COLOR(3)) + COLOR(4)=MAX(0.0,COLOR(4)) + CMDSTR=' ' + IF(IFILL .EQ.4) THEN + WRITE(CMDSTR,'(3(F7.3,1X),A6)') + > COLOR(1),COLOR(2),COLOR(3),'FSchsb' + ELSE IF(IFILL.EQ.3) THEN + WRITE(CMDSTR,'(4(F7.3,1X),A6)') + > COLOR(1),COLOR(2),COLOR(3),COLOR(4),'FScmyk' + ELSE IF(IFILL.EQ.2) THEN + WRITE(CMDSTR,'(3(F7.3,1X),A6)') + > COLOR(1),COLOR(2),COLOR(3),'FScrgb' + ELSE IF(IFILL.EQ.1) THEN + WRITE(CMDSTR,'(1(F7.3,1X),A6)') + > COLOR(1),'FSgray' + ELSE + WRITE(CMDSTR,'(1(F7.3,1X),A6)') + > 0.0,'FSgray' + ENDIF + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSFRAI.f b/Utilib/src/PSFRAI.f new file mode 100644 index 0000000..3ad4640 --- /dev/null +++ b/Utilib/src/PSFRAI.f @@ -0,0 +1,102 @@ +*DECK PSFRAI + SUBROUTINE PSFRAI(ISPSP,NSEG,IORDER,CENTER,RADANG) +C +C------------------------- PSFRAI ------------------------------- +C +C 1- SUBROUTINE STATISTICS: +C NAME : PSFRAI +C USE : FILL RECTANGULAR/ANNULAR INTERSECTION +C +C 2- PARAMETERS: +C INPUT +C ISPSP : POSTSCRIPT STRUCTURE I +C NSEG : NUMBER OF REGION INTERSECTION I +C NUMBER OF SEGMENTS IS NSEG-1 +C IORDER : TYPE OF REGION R(NSEG) +C = -2 : ARC SEGMENT BEGINS +C = -1 : ARC SEGMENT ENDS +C = 0 : CLOSE PATH +C > 0 : CORNER +C CENTER : X AND Y POSITION OF ANNULUS CENTER R(2) +C RADANG : SEGMENTS INTERSECTION POINTS R(2,NSEG) +C WITH RESPECT TO ANNULAR REGION CENTER +C RADANG(1) = RADIAL POSITION +C RADANG(2) = ANGULAR POSITION +C +C---------------------------------------------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NSEG + INTEGER IORDER(NSEG) + REAL CENTER(2),RADANG(2,NSEG) +C---- +C LOCAL PARAMETERS +C---- + REAL CONVER,PI + CHARACTER NAMSBR*6 + PARAMETER (CONVER=72.0,PI=3.1415926535897932, + > NAMSBR='PSFRAI') + CHARACTER CMDSTR*132 + INTEGER IPT,IDEP,IFIN + REAL XYDEP(2),ANGL(2),XYFIN(2) +C---- +C POSITION REFERENCE POINT AT CENTER OF ANNULAR REGION +C---- + XYDEP(1)=CENTER(1) + XYDEP(2)=CENTER(2) + CALL PSMOVE(ISPSP,XYDEP,-3) +C---- +C MOVE TO FIRST POINT +C---- + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + IDEP=IORDER(1) + XYDEP(1)=RADANG(1,1)*COS(RADANG(2,1)) + XYDEP(2)=RADANG(1,1)*SIN(RADANG(2,1)) + ANGL(1)=180.0*RADANG(2,1)/PI + IF(IDEP .EQ. -1 .OR. IDEP .GT. 0) THEN + CALL PSMOVE(ISPSP,XYDEP,3) + ENDIF +C---- +C SCAN SEGMENTS +C---- + DO 100 IPT=2,NSEG + CMDSTR=' ' + IFIN=IORDER(IPT) + XYFIN(1)=RADANG(1,IPT)*COS(RADANG(2,IPT)) + XYFIN(2)=RADANG(1,IPT)*SIN(RADANG(2,IPT)) + IF (IDEP .EQ. -2) THEN +C---- +C ARC SEGMENT +C FIND ANGLES ASSOCIATED WITH ARC +C---- + ANGL(2)=180.0*RADANG(2,IPT)/PI + IF(ANGL(2) .LT. ANGL(1)) THEN + ANGL(2)=ANGL(2)+360.0 + ENDIF + WRITE(CMDSTR,'(5(F8.2,1X),A3)') + > 0.0,0.0,RADANG(1,IPT)*CONVER,ANGL(1),ANGL(2),'arc' + CALL PSCPUT(ISPSP,CMDSTR) + ELSE +C---- +C LINE +C---- + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYFIN(1)*CONVER,XYFIN(2)*CONVER,'L' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + IDEP=IFIN + XYDEP(1)=XYFIN(1) + XYDEP(2)=XYFIN(2) + ANGL(1)=180.0*RADANG(2,IPT)/PI + 100 CONTINUE +C---- +C RESET REFERENCE POINT AT ORIGINAL POSITION +C---- + CMDSTR='cf' + CALL PSCPUT(ISPSP,CMDSTR) + XYDEP(1)=-CENTER(1) + XYDEP(2)=-CENTER(2) + CALL PSMOVE(ISPSP,XYDEP,-3) + RETURN + END diff --git a/Utilib/src/PSFREG.f b/Utilib/src/PSFREG.f new file mode 100644 index 0000000..822d9a3 --- /dev/null +++ b/Utilib/src/PSFREG.f @@ -0,0 +1,45 @@ +*DECK PSFREG + SUBROUTINE PSFREG(ISPSP,NPTS,XYPTS) +C +C--------------------------- PSFREG --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSFREG +C USE : FILL REGION +C REPLACES PSPLOT ROUTINE FILRGNC +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C NPTS : NUMBER OF POINTS I +C YXPTS : POSITION (X,Y) OF LINE INTERSECTION R(2,NPTS) +C +C--------------------------- PSFREG -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NPTS + REAL XYPTS(2,NPTS) +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSFREG',CONVER=72.0) + INTEGER IPT + CHARACTER CMDSTR*132 + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYPTS(1,1)*CONVER,XYPTS(2,1)*CONVER,'M' + CALL PSCPUT(ISPSP,CMDSTR) + DO 100 IPT=2,NPTS + CMDSTR=' ' + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYPTS(1,IPT)*CONVER,XYPTS(2,IPT)*CONVER,'L' + CALL PSCPUT(ISPSP,CMDSTR) + 100 CONTINUE + CMDSTR='cf' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSHEAD.f b/Utilib/src/PSHEAD.f new file mode 100644 index 0000000..e4ced38 --- /dev/null +++ b/Utilib/src/PSHEAD.f @@ -0,0 +1,268 @@ +*DECK PSHEAD + SUBROUTINE PSHEAD(ISPSP,NAMPSP,PROGNM) +C +C--------------------------- PSHEAD --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSHEAD +C USE : SET POSTSCRIPT HEADER +C REPLACES PART OF PSPLOT ROUTINE PSINIT +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C NAMPSP : PSP FILE NAME C*12 +C PROGNM : PAGE PROGRAM NAME C*6 +C--------------------------- PSHEAD -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + CHARACTER NAMPSP*12,PROGNM*6 +C---- +C LOCAL VARIABLES +C---- + REAL CONVER + CHARACTER NAMSBR*6 + PARAMETER (CONVER=72.0,NAMSBR='PSHEAD') + CHARACTER CMDSTR*132 +C---- +C PREPARE HEADER +C---- + CMDSTR='%!PS-Adobe-2.0 EPSF-2.0' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR= '%%Title: '//NAMPSP + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR= '%%CreationDate: 1999/03/29' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR= '%%Created with: PSPLOT PostScript Plotting Package'// + > ' in '//PROGNM + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR= '%%Reference: Kevin E. Kohler '// + > '<kevin@ocean.nova.edu> '// + > '- DRAGON implementation' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='%%EndComments' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/inch {72 mul} bind def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Ah {moveto lineto lineto stroke} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Ar {moveto 2 copy lineto 4 -2 roll' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' moveto lineto lineto stroke } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/arcit {S /A2 exch def /A1 exch def /Rad exch def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /Yc exch def /Xc exch def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' Xc Rad A1 cos mul add Yc Rad A1 sin mul add' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' moveto newpath' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' Xc Yc Rad A1 A2 arc stroke} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/C {/Rad exch def /Yc exch def /Xc exch def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' Xc Yc Rad 0 360 arc closepath' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/c0sf {closepath 0 setgray fill} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/cf {closepath fill} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Cs {closepath stroke} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Cln {newpath 3 1 roll' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' moveto {lineto} repeat clip newpath' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Cs {closepath stroke} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Fb {newpath moveto ' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' Dx 0 rlineto 0 Dy rlineto Dx neg 0 rlineto closepath' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' fill } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Fbn { newpath 3 1 roll moveto {lineto} repeat' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' closepath fill } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Fbnc { newpath 3 1 roll moveto' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {lineto} repeat closepath fill } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/L /lineto load def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Lend {/Strlen exch stringwidth pop def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Lendi {/Strlen exch stringwidth pop 1.5 mul def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Lends {/Strlen exch stringwidth pop 1.1 mul def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Lenssd '// + > '{/Strlenss exch stringwidth pop 3 mul 4 div def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/LSM {2 copy lineto stroke moveto} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/lsm {Xp Yp lineto stroke mover} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/M /moveto load def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/mover {Xp Yp moveto} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Np {newpath} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/S /stroke load def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Scrgb {setrgbcolor} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Scmyk {setcmykcolor} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Schsb {sethsbcolor} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Sgray {setgray} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/FScrgb {setrgbcolor fill} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/FScmyk {setcmykcolor fill} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/FSchsb {sethsbcolor fill} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/FSgray {setgray fill} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Setf {Curfnt exch scalefont setfont} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/SM {stroke moveto} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/sm {stroke mover} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(6H/Slw {,f7.4,22H mul setlinewidth} def)') CONVER + CALL PSCPUT(ISPSP,CMDSTR) + WRITE(CMDSTR,'(7H/SSlw {,f7.4,29H mul setlinewidth stroke} def)') + > CONVER + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Slw0 {.24 setlinewidth} bind def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/SSlw0 {.24 setlinewidth stroke} bind def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR= '%Line Breaking Procedure' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/TurnLineFL' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' { /T exch def /spacewidth space stringwidth pop def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /currentw 0 def /wordspace_count 0 def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /restart 0 def /remainder T def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {remainder space search' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {/nextword exch def pop' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /remainder exch def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /nextwordwidth nextword stringwidth pop def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' currentw nextwordwidth add lw gt' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {T restart wordspace_count restart sub' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' getinterval showline' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /restart wordspace_count def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /currentw nextwordwidth spacewidth add def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' }' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {/currentw currentw nextwordwidth add' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' spacewidth add def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' } ' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ifelse' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /wordspace_count wordspace_count' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' nextword length add 1 add def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' }' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {pop exit}' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ifelse' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' } loop' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /lrem remainder stringwidth pop def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' currentw lrem add lw gt' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {T restart wordspace_count restart sub ' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' getinterval showline remainder showline}' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' {/lastchar T length def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' T restart lastchar restart sub getinterval ' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' lm y moveto show}' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ifelse' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /parms {/y exch def /lm exch def /rm exch def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /leading exch def /pointsize exch def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /lw rm lm sub def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' findfont pointsize scalefont setfont ' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /showline {lm y moveto show' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' /y y leading sub def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' lm y moveto } def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Xposd {/Xpos exch def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Xposjd '// + > '{/Xpos exch Xpos exch Strlen mul sub def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/xydef {/Xp Xpos def /Yp Ypos def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='%/Xypd {/Yp exch def /Xp exch def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Xypos0d {/Xpos0 Xpres def /Ypos0 Ypres def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Xyprset {dup '// + > '/Xpres exch cos Strlen mul Xpos add def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' '// + > '/Ypres exch sin Strlen mul Ypos add def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Xyprset0 {dup '// + > '/Xpres exch cos Strlen mul Xpos0 add def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' '// + > '/Ypres exch sin Strlen mul Ypos0 add def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Yposd {/Ypos exch def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/Yposjd '// + > '{/Ypos exch Ypos exch Strlen mul sub def} def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='%%EndProlog' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR='/space ( ) def' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSLINW.f b/Utilib/src/PSLINW.f new file mode 100644 index 0000000..546f8b4 --- /dev/null +++ b/Utilib/src/PSLINW.f @@ -0,0 +1,42 @@ +*DECK PSLINW + SUBROUTINE PSLINW(ISPSP,WLINE) +C +C--------------------------- PSLINW --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSLINW +C USE : SET LINE WIDTH +C REPLACES PSPLOT ROUTINE SETLW +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C WLINE : WIDTH OF LINE R +C +C--------------------------- PSLINW -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + REAL WLINE +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='PSLINW') + CHARACTER CMDSTR*132 +C---- +C SET LINE WIDTH +C MINIMUM IS 0.00001 +C---- + CMDSTR=' ' + WRITE(CMDSTR,'(F7.3,1X,A5)') 0.0,'Sgray' + CALL PSCPUT(ISPSP,CMDSTR) + IF(ABS(WLINE).LT.1.E-5) THEN + CMDSTR='Slw0' + ELSE + CMDSTR=' ' + WRITE(CMDSTR,'(F7.3,1X,A3)') WLINE,'Slw' + ENDIF + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSMOVE.f b/Utilib/src/PSMOVE.f new file mode 100644 index 0000000..68b68b4 --- /dev/null +++ b/Utilib/src/PSMOVE.f @@ -0,0 +1,59 @@ +*DECK PSMOVE + SUBROUTINE PSMOVE(ISPSP,XYPOS,ITMOVE) +C +C--------------------------- PSMOVE --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSMOVE +C USE : MOVE PLOT REFERENCE POINT +C REPLACES PSPLOT ROUTINE PLOT +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C YXPOS : FINAL (X,Y) POSITION TO REACH R(2) +C ITMOVE : TYPE OF DISPLACEMENT +C +C--------------------------- PSMOVE -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,ITMOVE + REAL XYPOS(2) +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSMOVE',CONVER=72.0) + CHARACTER CMDSTR*132 +C---- +C IF ITMOVE=999 TERMINATE PLOT SESSION +C---- + IF(ITMOVE .EQ. 999) THEN + CMDSTR='stroke showpage' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + ENDIF +C---- +C MOVE WITH PEN UP (3) OR DOWN (OTHER VALUES) AS REQUESTED +C---- + CMDSTR=' ' + IF(ABS(ITMOVE).EQ.3) THEN + WRITE(CMDSTR,'(2(F8.2,1X),A2)') + > XYPOS(1)*CONVER,XYPOS(2)*CONVER,'SM' + ELSE + WRITE(CMDSTR,'(2(F8.2,1X),A3)') + > XYPOS(1)*CONVER,XYPOS(2)*CONVER,'LSM' + ENDIF + CALL PSCPUT(ISPSP,CMDSTR) +C---- +C RESET ORIGIN IF ITMOVE < 0 +C---- + CMDSTR=' ' + IF(ITMOVE.LT.0) THEN + WRITE(CMDSTR,'(2(F8.2,1X),A9)') + > XYPOS(1)*CONVER,XYPOS(2)*CONVER,'translate' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + RETURN + END diff --git a/Utilib/src/PSPAGE.f b/Utilib/src/PSPAGE.f new file mode 100644 index 0000000..11a20f9 --- /dev/null +++ b/Utilib/src/PSPAGE.f @@ -0,0 +1,60 @@ +*DECK PSPAGE + SUBROUTINE PSPAGE(ISPSP,NPAGE,XYPOS) +C +C--------------------------- PSPAGE --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSPAGE +C USE : SET POSTSCRIPT NEW PAGE +C REPLACES PART OF PSPLOT ROUTINE CHOPIT +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C NPAGE : PAGE NUMBER I +C XYPOS : ORIGIN OF PAGE R(2) +C--------------------------- PSPAGE -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NPAGE + REAL XYPOS(2) +C---- +C LOCAL VARIABLES +C---- + INTEGER MCOLR + CHARACTER NAMSBR*6 + PARAMETER (MCOLR=4,NAMSBR='PSPAGE') + INTEGER ICOLR + CHARACTER CMDSTR*132 + REAL COLR(MCOLR) +C---- +C INITIALIZE COLOR, XYPOS TO 0.0 +C---- + DO 100 ICOLR=1,MCOLR + COLR(ICOLR)=0.0 + 100 CONTINUE + CMDSTR=' ' + WRITE(CMDSTR,'(A8,2(I4,1X))') '%%Page: ',NPAGE,NPAGE + CALL PSCPUT(ISPSP,CMDSTR) + IF(NPAGE .GT. 1) THEN + CMDSTR='newpath 0 0 moveto' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + CMDSTR='/Curfnt /Times-Italic findfont def' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' 12 Setf' + CALL PSCPUT(ISPSP,CMDSTR) + IF(NPAGE .EQ. 1) THEN + CMDSTR=' 1.000 1.000 scale' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + CALL PSLINW(ISPSP,COLR) + CMDSTR=' ' + WRITE(CMDSTR,'(F7.3,1X,A5)') 0.0,'Sgray' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(3(F7.3,1X),A5)') 0.0,0.0,0.0,'Scrgb' + CALL PSCPUT(ISPSP,CMDSTR) + CALL PSMOVE(ISPSP,XYPOS,-3) + RETURN + END diff --git a/Utilib/src/PSSARC.f b/Utilib/src/PSSARC.f new file mode 100644 index 0000000..8619c76 --- /dev/null +++ b/Utilib/src/PSSARC.f @@ -0,0 +1,36 @@ +*DECK PSSARC + SUBROUTINE PSSARC(ISPSP,XYCENT,RADIUS,ANGR) +C +C--------------------------- PSSARC --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSSARC +C USE : DRAW CIRCLE +C ADAPTED FROM PSPLOT ROUTINE ARC +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C YXCENT : POSITION (X,Y) OF LINE INTERSECTION R(2) +C RADIUS : ARC RADIUS R +C ANGR : ARC ANGLE RANGE R(2) +C +C--------------------------- PSSARC -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + REAL XYCENT(2),RADIUS,ANGR(2) +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSSARC',CONVER=72.0) + CHARACTER CMDSTR*132 + CMDSTR=' ' + WRITE(CMDSTR,'(5(F8.2,1X),A5)') + > XYCENT(1)*CONVER,XYCENT(2)*CONVER,RADIUS*CONVER, + > ANGR(1),ANGR(2),'arcit' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSSCIR.f b/Utilib/src/PSSCIR.f new file mode 100644 index 0000000..428897d --- /dev/null +++ b/Utilib/src/PSSCIR.f @@ -0,0 +1,36 @@ +*DECK PSSCIR + SUBROUTINE PSSCIR(ISPSP,XYCENT,RADIUS) +C +C--------------------------- PSSCIR --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSSCIR +C USE : DRAW ARC +C ADAPTED FROM PSPLOT ROUTINE CIRCLE +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C YXCENT : POSITION (X,Y) OF LINE INTERSECTION R(2) +C RADIUS : ARC RADIUS R +C +C--------------------------- PSSCIR -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + REAL XYCENT(2),RADIUS +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSSCIR',CONVER=72.0) + CHARACTER CMDSTR*132 + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(3(F8.2,1X),A8)') + > XYCENT(1)*CONVER,XYCENT(2)*CONVER,RADIUS*CONVER,'C stroke' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSSRAI.f b/Utilib/src/PSSRAI.f new file mode 100644 index 0000000..0459c27 --- /dev/null +++ b/Utilib/src/PSSRAI.f @@ -0,0 +1,102 @@ +*DECK PSSRAI + SUBROUTINE PSSRAI(ISPSP,NSEG,IORDER,CENTER,RADANG) +C +C------------------------- PSSRAI ------------------------------- +C +C 1- SUBROUTINE STATISTICS: +C NAME : PSSRAI +C USE : DRAW RECTANGULAR/ANNULAR INTERSECTION +C +C 2- PARAMETERS: +C INPUT +C ISPSP : POSTSCRIPT STRUCTURE I +C NSEG : NUMBER OF REGION INTERSECTION I +C NUMBER OF SEGMENTS IS NSEG-1 +C IORDER : TYPE OF REGION R(NSEG) +C = -2 : ARC SEGMENT BEGINS +C = -1 : ARC SEGMENT ENDS +C = 0 : CLOSE PATH +C > 0 : CORNER +C CENTER : X AND Y POSITION OF ANNULUS CENTER R(2) +C RADANG : SEGMENTS INTERSECTION POINTS R(2,NSEG) +C WITH RESPECT TO ANNULAR REGION CENTER +C RADANG(1) = RADIAL POSITION +C RADANG(2) = ANGULAR POSITION +C +C---------------------------------------------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NSEG + INTEGER IORDER(NSEG) + REAL CENTER(2),RADANG(2,NSEG) +C---- +C LOCAL PARAMETERS +C---- + REAL CONVER,PI + CHARACTER NAMSBR*6 + PARAMETER (CONVER=72.0,PI=3.1415926535897932, + > NAMSBR='PSSRAI') + CHARACTER CMDSTR*132 + INTEGER IPT,IDEP,IFIN + REAL XYDEP(2),ANGL(2),XYFIN(2) +C---- +C POSITION REFERENCE POINT AT CENTER OF ANNULAR REGION +C---- + XYDEP(1)=CENTER(1) + XYDEP(2)=CENTER(2) + CALL PSMOVE(ISPSP,XYDEP,-3) +C---- +C MOVE TO FIRST POINT +C---- + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + IDEP=IORDER(1) + XYDEP(1)=RADANG(1,1)*COS(RADANG(2,1)) + XYDEP(2)=RADANG(1,1)*SIN(RADANG(2,1)) + ANGL(1)=180.0*RADANG(2,1)/PI + IF(IDEP .EQ. -1 .OR. IDEP .GT. 0) THEN + CALL PSMOVE(ISPSP,XYDEP,3) + ENDIF +C---- +C SCAN SEGMENTS +C---- + DO 100 IPT=2,NSEG + CMDSTR=' ' + IFIN=IORDER(IPT) + XYFIN(1)=RADANG(1,IPT)*COS(RADANG(2,IPT)) + XYFIN(2)=RADANG(1,IPT)*SIN(RADANG(2,IPT)) + IF (IDEP .EQ. -2) THEN +C---- +C ARC SEGMENT +C FIND ANGLES ASSOCIATED WITH ARC +C---- + ANGL(2)=180.0*RADANG(2,IPT)/PI + IF(ANGL(2) .LT. ANGL(1)) THEN + ANGL(2)=ANGL(2)+360.0 + ENDIF + WRITE(CMDSTR,'(5(F8.2,1X),A3)') + > 0.0,0.0,RADANG(1,IPT)*CONVER,ANGL(1),ANGL(2),'arc' + CALL PSCPUT(ISPSP,CMDSTR) + ELSE +C---- +C LINE +C---- + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYFIN(1)*CONVER,XYFIN(2)*CONVER,'L' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + IDEP=IFIN + XYDEP(1)=XYFIN(1) + XYDEP(2)=XYFIN(2) + ANGL(1)=180.0*RADANG(2,IPT)/PI + 100 CONTINUE +C---- +C RESET REFERENCE POINT AT ORIGINAL POSITION +C---- + CMDSTR='Cs' + CALL PSCPUT(ISPSP,CMDSTR) + XYDEP(1)=-CENTER(1) + XYDEP(2)=-CENTER(2) + CALL PSMOVE(ISPSP,XYDEP,-3) + RETURN + END diff --git a/Utilib/src/PSSREG.f b/Utilib/src/PSSREG.f new file mode 100644 index 0000000..69a640d --- /dev/null +++ b/Utilib/src/PSSREG.f @@ -0,0 +1,45 @@ +*DECK PSSREG + SUBROUTINE PSSREG(ISPSP,NPTS,XYPTS) +C +C--------------------------- PSSREG --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSSREG +C USE : DRAW REGION +C ADAPTED FROM PSPLOT ROUTINE FILRGNC +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C NPTS : NUMBER OF POINTS I +C YXPTS : POSITION (X,Y) OF LINE INTERSECTION R(2,NPTS) +C +C--------------------------- PSSREG -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NPTS + REAL XYPTS(2,NPTS) +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + REAL CONVER + PARAMETER (NAMSBR='PSSREG',CONVER=72.0) + INTEGER IPT + CHARACTER CMDSTR*132 + CMDSTR='Np' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYPTS(1,1)*CONVER,XYPTS(2,1)*CONVER,'M' + CALL PSCPUT(ISPSP,CMDSTR) + DO 100 IPT=2,NPTS + CMDSTR=' ' + WRITE(CMDSTR,'(2(F8.2,1X),A1)') + > XYPTS(1,IPT)*CONVER,XYPTS(2,IPT)*CONVER,'L' + CALL PSCPUT(ISPSP,CMDSTR) + 100 CONTINUE + CMDSTR='Cs' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSSTRK.f b/Utilib/src/PSSTRK.f new file mode 100644 index 0000000..e80a68e --- /dev/null +++ b/Utilib/src/PSSTRK.f @@ -0,0 +1,57 @@ +*DECK PSSTRK + SUBROUTINE PSSTRK(ISPSP,WLINE,KSS,KSR) +C +C--------------------------- PSSTRK --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSSTRK +C USE : SET LINE WIDTH AND STROKE PATH +C REPLACES PSPLOT ROUTINE SETLW +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C WLINE : WIDTH OF LINE R +C KSS : FLAG TO SAVE DRAWING BEFORE FILLING I +C = 0 : NO SAVE +C = 1 : SAVE +C KSR : FLAG TO RESTORE DRAWING BEFORE FILLING I +C = 0 : NO RESTORE +C = 1 : RESTORE +C +C--------------------------- PSSTRK -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP + REAL WLINE + INTEGER KSS,KSR +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='PSSTRK') + CHARACTER CMDSTR*132 +C---- +C SET LINE WIDTH +C MINIMUM IS 0.00001 +C---- + IF(KSR .EQ. 1) THEN + CMDSTR='grestore' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + IF(KSS .EQ. 1) THEN + CMDSTR='gsave' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + CMDSTR=' ' + WRITE(CMDSTR,'(F7.3,1X,A5)') 0.0,'Sgray' + CALL PSCPUT(ISPSP,CMDSTR) + IF(ABS(WLINE).LT.1.E-5) THEN + CMDSTR='SSlw0' + ELSE + CMDSTR=' ' + WRITE(CMDSTR,'(F7.3,1X,A4)') WLINE,'SSlw' + ENDIF + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/PSTEXT.f b/Utilib/src/PSTEXT.f new file mode 100644 index 0000000..a780d98 --- /dev/null +++ b/Utilib/src/PSTEXT.f @@ -0,0 +1,135 @@ +*DECK PSTEXT + SUBROUTINE PSTEXT(ISPSP,NBCAR,TEXT,XYPOS,HEIGHT,JUST,ANGL) +C +C--------------------------- PSTEXT --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSTEXT +C USE : PRINT POSTSCRIPT TEXT +C ADAPTED FROM PSPLOT ROUTINE KELSYMC +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C NBCAR : NUMBER OF CHARACTER TO PRINT I +C TEXT : TEXT TO PRINT C*(*) +C YXPOS : POSITION OF TEXT R(2) +C HEIGHT : TEXT HEIGHT R +C JUST : JUSTIFICATION I +C = 0 CENTER +C = 1 LEFT +C = 2 RIGHT +C ANGL : TEXT ROTATION ANGLE R +C LOCAL +C IBSL : ASCII REPRESENTATION OF BACKSLASH I +C +C--------------------------- PSTEXT -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,NBCAR,JUST + CHARACTER TEXT*(*) + REAL XYPOS(2),HEIGHT,ANGL +C---- +C LOCAL VARIABLES +C---- + INTEGER IBSL,MXCHAR + CHARACTER NAMSBR*6 + REAL CONVER,SZRAT,PI + PARAMETER (IBSL=92,MXCHAR=80,NAMSBR='PSTEXT', + > CONVER=72.0,SZRAT=0.6,PI=3.1415926535897932) + INTEGER IHT,ICHAR,NRCHAR,LJUST + CHARACTER CBSL*1,CMDSTR*132,LINE*(MXCHAR), + > CADD*16,CBDD*16 + REAL STRLEN,ANGD,XYROT(2) +C---- +C STROKE PREVIOUS PATHS BEFORE THIS WRITE +C---- + CBSL=CHAR(IBSL) + CMDSTR='S' + CALL PSCPUT(ISPSP,CMDSTR) +C---- +C SET CURRENT CHARACTER SIZE +C---- + IHT=INT(HEIGHT*CONVER/SZRAT) + IF(IHT .NE. 12) THEN + CMDSTR=' ' + WRITE(CMDSTR,'(I3,1X,A4)') IHT,'Setf' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF +C---- +C CHECK IF TEXT CONTAINS ( OR ) OR "Backslash". +C THESE CHARACTERS ARE TREATED BY PRECEDING THEM WITH A "Backslash". +c DO THIS TO ( AND ) EVEN THOU +C THEY MIGHT BE BALANCED, I.E. () WITHIN A STRING, WHICH CAN BE TREATED +C NORMALLY. +C---- + NRCHAR=1 + LINE='(' + DO 100 ICHAR=1,NBCAR + IF(TEXT(ICHAR:ICHAR).EQ.'(' .OR. + > TEXT(ICHAR:ICHAR).EQ.')' .OR. + > TEXT(ICHAR:ICHAR).EQ.CBSL ) THEN + IF(NRCHAR .EQ. MXCHAR-6) THEN + GO TO 105 + ENDIF + NRCHAR=NRCHAR+1 + LINE(NRCHAR:NRCHAR)=CBSL + ENDIF + IF(NRCHAR .EQ. MXCHAR-6) THEN + GO TO 105 + ENDIF + NRCHAR=NRCHAR+1 + LINE(NRCHAR:NRCHAR)=TEXT(ICHAR:ICHAR) + 100 CONTINUE + 105 CONTINUE + NRCHAR=NRCHAR+1 + LINE(NRCHAR:NRCHAR+5)=') Lend' +C---- +C CHARACTER SPACE HEIGHT IS 2.0 X CHAR HEIGHT +C CHARACTER SPACE WIDTH IS 1.5 X CHAR WIDTH +C ACTUAL TEXT LENGTH IS NRCHAR-2 +C ACTUAL STRING LENGTH IS (NRCHAR-3)*1.5*CHAR WIDTH + CHAR WIDTH +C OR CHAR WIDHT*(1.5*NRCHAR-4.5+1)=CHAR WIDHT*(1.5*NRCHAR-3.5) +C---- + STRLEN=(HEIGHT*SZRAT)*(1.5*NRCHAR-3.5) + ANGD=ANGL*PI/180.0 + CMDSTR=' ' + WRITE(CMDSTR,'(F8.2,1X,A5)') XYPOS(1)*CONVER,'Xposd' + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(F8.2,1X,A5)') XYPOS(2)*CONVER,'Yposd' + CALL PSCPUT(ISPSP,CMDSTR) +C---- +C CHECH FOR VALID JUSTIFICATION. +C IF NOT VALID SET TO CENTERED +C---- + LJUST=JUST + IF(LJUST .LT. 0 .AND. LJUST .GT. 2) THEN + LJUST=0 + ENDIF + XYROT(1)=COS(ANGD)*LJUST/2. + XYROT(2)=SIN(ANGD)*LJUST/2. + CADD=' ' + CBDD=' ' + IF(XYROT(1) .NE. 0.0 ) THEN + WRITE(CADD,'(1X,F7.3,1X,A6)') XYROT(1),'Xposjd' + ENDIF + IF(XYROT(2) .NE. 0.0 ) THEN + WRITE(CBDD,'(1X,F7.3,1X,A6)') XYROT(2),'Yposjd' + ENDIF + CMDSTR=LINE(1:NRCHAR+5)//CADD//CBDD + CALL PSCPUT(ISPSP,CMDSTR) + LINE(NRCHAR:NRCHAR+5)=') show' + CADD=' ' + CBDD=' ' + IF(ANGL.NE.0.) THEN + WRITE(CADD,'(1X,F7.1,1X,A7)') ANGL,'rotate ' + WRITE(CBDD,'(1X,F7.1,1X,A7)') -ANGL,'rotate ' + ENDIF + CMDSTR='xydef mover'//CADD//LINE(1:NRCHAR+5)//CBDD + CALL PSCPUT(ISPSP,CMDSTR) + CMDSTR=' ' + WRITE(CMDSTR,'(F6.1,1X,A7)') ANGL,'Xyprset' + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END diff --git a/Utilib/src/RANDD.f b/Utilib/src/RANDD.f new file mode 100644 index 0000000..c986f6c --- /dev/null +++ b/Utilib/src/RANDD.f @@ -0,0 +1,70 @@ +*DECK RANDD + SUBROUTINE RANDD(ISEED,NRAND,DRAND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* This subroutine returns a pseudo-random number for each invocation. +* It is a FORTRAN 77 adaptation of the "Integer Version 2" minimal +* standard number generator whose Pascal code appears in reference. +* This is the double precision version of the single precision +* routine RANDF. +* +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* ISEED the seed for the generation of random numbers. If ISEED=0 +* use ISEED=3141592654 +* NRAND number of random number requested. +* +*Parameters: ouput +* DRAND random numbers between 0 and 1. +* +*Reference: +* Park, Steven K. and Miller, Keith W., "Random Number Generators: +* Good Ones are Hard to Find", Communications of the ACM, October 1988. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISEED,NRAND + DOUBLE PRECISION DRAND(NRAND) +*---- +* LOCAL VARIABLES +*---- + INTEGER MPLIER,MODLUS,MOBYMP,MOMDMP + PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773, + + MOMDMP=2836) + INTEGER IRAND,HVLUE,LVLUE,TESTV,NEXTN +* + IF(ISEED .EQ. 0) THEN + NEXTN = 314159265 + ELSE + NEXTN = ISEED + ENDIF +* + DO IRAND=1,NRAND + HVLUE = NEXTN / MOBYMP + LVLUE = MOD(NEXTN, MOBYMP) + TESTV = MPLIER*LVLUE - MOMDMP*HVLUE + IF (TESTV .GT. 0) THEN + NEXTN = TESTV + ELSE + NEXTN = TESTV + MODLUS + ENDIF + DRAND(IRAND) = DBLE(NEXTN)/DBLE(MODLUS) + ENDDO + ISEED= NEXTN + RETURN + END diff --git a/Utilib/src/RANDDN.f b/Utilib/src/RANDDN.f new file mode 100644 index 0000000..823cb36 --- /dev/null +++ b/Utilib/src/RANDDN.f @@ -0,0 +1,78 @@ +*DECK RANDDN + SUBROUTINE RANDDN(ISEED,NRAND,DRANDN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* This subroutine generates pseudo-random numbers +* from a normal distribution of width 1 centered at 0.0. +* +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* +*Author(s): G. Marleau +* +*Parameters: input +* ISEED the seed for the generation of random numbers. +* NRAND number of random number requested. +* +*Parameters: ouput +* DRANDN random numbers between picked from +* a normal distribution of width 1 centered at 0 . +* +*Reference: +* Box-Muller method. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISEED,NRAND + DOUBLE PRECISION DRANDN(NRAND) +*---- +* Parameters +*---- + DOUBLE PRECISION TWOPI + PARAMETER (TWOPI=6.283185307179586D0) +*---- +* LOCAL VARIABLES +*---- + INTEGER IRAND,NSTEP,ISTEP + DOUBLE PRECISION DXRAND(2),DSRAND +*---- +* Saved variables +*---- + INTEGER INEXT + DOUBLE PRECISION DLAST + SAVE INEXT,DLAST + DATA INEXT/0/ + DATA DLAST/0.0D0/ +*---- +* Pick 2 random numbers +*---- + NSTEP=(NRAND-INEXT)/2 + IF(INEXT .EQ. 1) THEN + DRANDN(INEXT)=DLAST + ENDIF + IRAND=INEXT+1 + DO ISTEP=1,NSTEP + CALL RANDD(ISEED,2,DXRAND) + DSRAND=SQRT(-2*LOG(DXRAND(1))) + DRANDN(IRAND)=DSRAND*COS(TWOPI*DXRAND(2)) + DRANDN(IRAND+1)=DSRAND*SIN(TWOPI*DXRAND(2)) + IRAND=IRAND+2 + ENDDO + IF(MOD(NRAND-INEXT,2) .EQ. 1) THEN + CALL RANDD(ISEED,2,DXRAND) + DSRAND=SQRT(-2*LOG(DXRAND(1))) + DRANDN(IRAND)=DSRAND*COS(TWOPI*DXRAND(2)) + DLAST=DSRAND*SIN(TWOPI*DXRAND(2)) + INEXT=1 + ELSE + INEXT=0 + ENDIF + RETURN + END diff --git a/Utilib/src/RANDF.f b/Utilib/src/RANDF.f new file mode 100644 index 0000000..9b9e6de --- /dev/null +++ b/Utilib/src/RANDF.f @@ -0,0 +1,65 @@ +*DECK RANDF + SUBROUTINE RANDF(ISEED,IFIRST,RAND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* This subroutine returns a pseudo-random number for each invocation. +* It is a FORTRAN 77 adaptation of the "Integer Version 2" minimal +* standard number generator whose Pascal code appears in reference. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* ISEED the seed for the generation of random numbers. +* IFIRST set to 1 to indicate that the seed is being generated. +* +*Parameters: ouput +* IFIRST set to 1 to indicate that the seed is being generated. +* RAND random number between 0 and 1. +* +*Reference: +* Park, Steven K. and Miller, Keith W., "Random Number Generators: +* Good Ones are Hard to Find", Communications of the ACM, October 1988. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISEED,IFIRST + REAL RAND + DOUBLE PRECISION D1,D2 +*---- +* LOCAL VARIABLES +*---- + INTEGER MPLIER,MODLUS,MOBYMP,MOMDMP + PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773, + + MOMDMP=2836) + INTEGER HVLUE, LVLUE, TESTV, NEXTN +* + IF (IFIRST .EQ. 0) IFIRST = 1 + NEXTN = ISEED +* + HVLUE = NEXTN / MOBYMP + LVLUE = MOD(NEXTN, MOBYMP) + TESTV = MPLIER*LVLUE - MOMDMP*HVLUE + IF (TESTV .GT. 0) THEN + NEXTN = TESTV + ELSE + NEXTN = TESTV + MODLUS + ENDIF + D1=DBLE(NEXTN) + D2=DBLE(MODLUS) + RAND=REAL(D1/D2) + ISEED= NEXTN + RETURN + END diff --git a/Utilib/src/RENDEG.f b/Utilib/src/RENDEG.f new file mode 100644 index 0000000..6794425 --- /dev/null +++ b/Utilib/src/RENDEG.f @@ -0,0 +1,48 @@ +*DECK RENDEG + FUNCTION RENDEG(N,LC,IM,MCU,NODE,MASK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the degree of a node in matrix graph in MSR format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N order of the system. +* LC size of MCU. +* IM +* MCU connection matrices which defines the graph of the ACA matrix. +* NODE node considered. +* MASK mask for node to be considered in this search. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER RENDEG + INTEGER N,LC,IM(N+1),MCU(LC),NODE,MASK(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER J,NJ +* + RENDEG=0 + DO J=IM(NODE)+1,IM(NODE+1) + NJ=MCU(J) + IF (NJ.GT.0) THEN + IF (MASK(NJ).EQ.1) RENDEG=RENDEG+1 + ENDIF + ENDDO +* + RETURN + END diff --git a/Utilib/src/RENINS.f b/Utilib/src/RENINS.f new file mode 100644 index 0000000..f5a1029 --- /dev/null +++ b/Utilib/src/RENINS.f @@ -0,0 +1,49 @@ +*DECK RENINS + SUBROUTINE RENINS(SIZE,LEV,DEG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Sort a level by increasing degree using the "Insertion method". +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* SIZE number of nodes in the level. +* LEV level to sort. +* DEG degrees of the level. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER SIZE,LEV(SIZE),DEG(SIZE) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,INDD,INDL,J +* + DO I=2,SIZE + INDD=DEG(I) + INDL=LEV(I) + J=I + DO WHILE ((J.GT.1).AND.(DEG(J-1).GT.INDD)) + DEG(J)=DEG(J-1) + LEV(J)=LEV(J-1) + J=J-1 + ENDDO + DEG(J)=INDD + LEV(J)=INDL + ENDDO +* + RETURN + END diff --git a/Utilib/src/RENLST.f b/Utilib/src/RENLST.f new file mode 100644 index 0000000..06cd860 --- /dev/null +++ b/Utilib/src/RENLST.f @@ -0,0 +1,105 @@ +*DECK RENLST + SUBROUTINE RENLST(N,LC,NFIRST,IM,MCU,TYPOR,NLEV,LEV,LEVPT,MASK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Level-set traversal method of the graph of a matrix stored +* in MSR format. +* +*Reference +* Y. Saad, "Iterative Methods for Sparse Linear Systems", +* PWS Publishing Company, Boston, 1996 +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N order of the system. +* LC size of MCU. +* NFIRST starting node. +* IM +* MCU connection matrices which defines the graph of the ACA matrix. +* TYPOR type of level traversal +* 0 : Breadth First Search +* 1 : Cuthill-McKee ordering +* +* Parameters: output +* NLEV number of level in the last level-set traversal. +* LEV +* LEVPT level data structure of the last level-set traversal. +* LEV(LEVPT(I):LEVPT(I+1)-1) : nodes in level i. +* MASK mask for node to be considered in this search. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,LC,NFIRST,IM(N+1),MCU(LC),TYPOR,NLEV,LEV(N), + 1 LEVPT(N+1),MASK(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER IDEB,IEND,NEWEND,I,NODE,J,NJ,RENDEG + INTEGER, DIMENSION(:), ALLOCATABLE :: DEG +* + ALLOCATE(DEG(N)) + MASK(:N)=1 + NLEV=1 + IDEB=1 + IEND=1 + LEVPT(NLEV)=IDEB + LEV(1)=NFIRST + MASK(NFIRST)=0 +* + DO WHILE (IEND.LT.N) +* visit neighboring nodes of nodes LEV(IDEB^in:IEND^in) + NEWEND=IEND + IF (TYPOR.EQ.1) THEN +* Cuthill McKee ordering +* find the degrees for this level + DO I=IDEB,IEND + NODE=LEV(I) + DEG(I-IDEB+1)=RENDEG(N,LC,IM,MCU,NODE,MASK) + ENDDO +* sort this level by increasing degrees + CALL RENINS((IEND-IDEB+1),LEV(IDEB),DEG) + ENDIF + DO I=IDEB,IEND + NODE=LEV(I) + DO J=IM(NODE)+1,IM(NODE+1) + NJ=MCU(J) + if (NJ.GT.0) THEN + if (MASK(NJ).EQ.1) THEN + NEWEND=NEWEND+1 + MASK(NJ)=0 + LEV(NEWEND)=NJ + ENDIF + ENDIF + ENDDO + ENDDO + IF (NEWEND.EQ.IEND) + 1 CALL XABORT('RENLST: INCOHERENT MATRIX GRAPH') + IDEB=IEND+1 + IEND=NEWEND +* unmarked neighbors are added in LEV(IDEB^out:IEND^out) +* where IDEB^out=IEND^in + 1 +* IEND^out=IEND^in + number of unmarked neighbors found +* start new level + NLEV=NLEV+1 + LEVPT(NLEV)=IEND+1 + ENDDO + NLEV=NLEV-1 +* + DEALLOCATE(DEG) +* + RETURN + END diff --git a/Utilib/src/RENUM.f b/Utilib/src/RENUM.f new file mode 100644 index 0000000..1cc1d7e --- /dev/null +++ b/Utilib/src/RENUM.f @@ -0,0 +1,99 @@ +*DECK RENUM + SUBROUTINE RENUM(N,LC,NFIRST,IM,MCU,TYPOR1,TYPOR2,NLEV,LEV,LEVPT, + 1 IPERM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Renumbering of the unknowns for ilu0 decomposition of the a matrix. +* level-set traversal method which starts by finding a pseudo-peripheral +* node of the graph of the matrix. +* +*Reference +* Y. Saad, "Iterative Methods for Sparse Linear Systems", +* PWS Publishing Company, Boston, 1996 +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N order of the system. +* LC size of MCU. +* IM +* MCU connection matrices which defines the graph of the ACA matrix. +* TYPOR1 type of level traversal for pseudo-peripheral node. +* TYPOR2 type of level traversal for the last level-set traversal. +* 0 : Breadth First Search +* 1 : Cuthill-McKee ordering +* +*Parameters: input/output +* NFIRST starting node for the traversal. +* +* Parameters: output +* NLEV number of level in the last level-set traversal. +* LEV +* LEVPT level data structure of the last level-set traversal. +* LEV(LEVPT(I):LEVPT(I+1)-1) : nodes in level i. +* IPERM permutation array: IPERM(I) : new index of node I. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,LC,NFIRST,IM(N+1),MCU(LC),TYPOR1,TYPOR2,NLEV,LEV(N), + 1 LEVPT(N+1),IPERM(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER DELTA,J,MINDEG,DEG,PPN + INTEGER RENDEG + LOGICAL NOTDONE +*--- +* PSEUDO-PERIPHERAL NODE SEARCH (IPERM IS USED AS A WORK ARRAY) +*--- + DELTA=0 + NOTDONE=.TRUE. + DO WHILE (NOTDONE) +* Level-set traversal (Breadth First Search or Cuthill Mc-Kee) from node NFIRST + CALL RENLST(N,LC,NFIRST,IM,MCU,TYPOR1,NLEV,LEV,LEVPT,IPERM) + IF (NLEV.GT.DELTA) THEN + MINDEG=N+1 +* scan last level of the previous expansion to find a node (PPN) +* with minimum degree + DO J=LEVPT(NLEV),LEVPT(NLEV+1)-1 + PPN=LEV(J) + DEG=RENDEG(N,LC,IM,MCU,PPN,IPERM) + IF (DEG.LT.MINDEG) THEN + MINDEG=DEG + NFIRST=PPN + ENDIF + ENDDO + DELTA=NLEV + ELSE + NOTDONE=.FALSE. + ENDIF + ENDDO +*--- +* LEVEL-SET TRAVERSAL FROM NODE NFIRST, A PSEUDO-PERIPHERAL NODE +*--- + IF (TYPOR1.NE.TYPOR2) THEN +* Level-set traversal (Breadth First Search or Cuthill Mc-Kee) from node NFIRST + CALL RENLST(N,LC,NFIRST,IM,MCU,TYPOR2,NLEV,LEV,LEVPT,IPERM) + ENDIF +*--- +* FORM IPERM ARRAY BY REVERSING THE ORDERING DEFINED BY THE LEV ARRAY +*--- + DO J=1,N + IPERM(J)=LEV(N-J+1) + ENDDO +* + RETURN + END diff --git a/Utilib/src/SALTSTEAM.f90 b/Utilib/src/SALTSTEAM.f90 new file mode 100644 index 0000000..17666e3 --- /dev/null +++ b/Utilib/src/SALTSTEAM.f90 @@ -0,0 +1,184 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 wrapper to calculate Molten Salt thermophysical +! properties using data from the MSTPDB-TP Database +! +!Copyright: +! Copyright (C) 2023 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): Cristian Garrido Tamm +! +!----------------------------------------------------------------------- +! +subroutine THMSGT(salt, compo, tp, impx) + ! Get the data from MSTDB-TP csv files for the specific salt "salt" with proportions "prop" + use t_saltdata + character*32, intent(in) :: salt, compo ! salt formula and composition + type(tpdata), intent(out) :: tp ! Tupla with Thermophysical properties + integer, intent(in) :: impx + + character(len=1000) :: line ! line of the csv file + character(len=255) :: filename = './MSTPDB.data' + + integer :: ios, i + + ! Initialize tp + tp%formula='' + tp%composition='' + + ! open file + open(18, file=filename, status='old') + + ! Read file line by line + i= 0 + do + i = i + 1 + read(18, '(a)', iostat=ios) line + if (ios /= 0) exit + if (impx > 5) write(*,*) "line=", line + if (i .gt. 1) then + read(line,*) tp + if (impx > 5) write(*,*) "tp=", tp + end if + if (tp%formula .eq. salt .and. tp%composition .eq. compo) then + if (impx > 5) write(*,*) "Found!" + exit + end if + end do + if (ios /= 0) then + if (impx > 5) write(*,*) "call xabort here" + write(*,*) 'THMSGT: salt=', salt, 'compo=', compo + call XABORT('Salt not found in MSTDB-TP') + end if + if (impx > 2) then + write(*,*) "tp%formula=", tp%formula + write(*,*) "tp%weight=", tp%weight + write(*,*) "tp%composition=", tp%composition + write(*,*) "tp%Tm=", tp%Tm + write(*,*) "tp%Tb=", tp%Tb + write(*,*) "tp%rhoA=", tp%rhoA + write(*,*) "tp%rhoB=", tp%rhoB + write(*,*) "tp%zmu1A=", tp%zmu1A + write(*,*) "tp%zmu1B=", tp%zmu1B + write(*,*) "tp%zmu2A=", tp%zmu2A + write(*,*) "tp%zmu2B=", tp%zmu2B + write(*,*) "tp%zmu2C=", tp%zmu2C + write(*,*) "tp%zkA=", tp%zkA + write(*,*) "tp%zkB=", tp%zkB + write(*,*) "tp%cpA=", tp%cpA + write(*,*) "tp%cpB=", tp%cpB + write(*,*) "tp%cpC=", tp%cpC + write(*,*) "tp%cpD=", tp%cpD + endif + close(18, status='keep') +end subroutine THMSGT + +subroutine THMSST(tp, tboil, impx) + ! return the boiling temperature for the molten salts (If it is 0 in the MSTPDB is set to 5000 K) + use t_saltdata + ! character*16 :: salt, compo ! salt formula and composition + real, intent(out) :: tboil + integer, intent(in) :: impx + ! + type(tpdata), intent(in) :: tp ! Tupla with Thermophysical properties + ! get the tpdata object for the specific salt + if (tp%tb.eq.0.0) then + tboil=5000 + else + tboil=tp%tb + endif + if (impx > 2) write(6,*) 'THMSST: BOILING TEMPERATURE=',tboil +end subroutine THMSST + +subroutine THMSPT(tp, t, zrho, h, zk, zmu, zcp, impx) + ! return the remaining thermohydraulics parameters as a function of the temperature (K) for molten salts + use t_saltdata + ! character*16 :: salt, compo ! salt formula and composition + real, intent(in) :: t + real, intent(out) :: zrho, h, zk, zmu, zcp + type(tpdata), intent(in) :: tp ! Tupla with Thermophysical properties + integer, intent(in) :: impx + ! + if(impx > 2) write(6,*) 'THSMPT: Molten salt thermophysical properties from MSTPDB' + ! get the tpdata object for the specific salt + zrho = dens(tp,t) + zk = cond(tp,t) + zmu = visc(tp,t) + zcp = cap(tp,t) + h = zcp*t + if (impx > 2) then + write(*,*) 'WEIGHT =', tp%weight + write(*,*) 'TEMPERATURE =', t, '(K)' + write(*,*) 'DENSITY =', zrho, '(kg/m3)' + write(*,*) 'VISCOSITY =', zmu, '(kg/m2/s)' + write(*,*) 'THERMAL CONDUCTIVITY =', zk, '(W/m/K)' + write(*,*) 'THERMAL CAPACITY =', zcp, '(J/K/kg)' + write(*,*) 'SPECIFIC ENTHALPY =', h, '(J/kg)' + endif + if (zrho <= 0.0) then + call XABORT('THMSPT: NEGATIVE SALT DENSITY.') + endif + if (zk <= 0.0) then + call XABORT('THMSPT: NEGATIVE SALT THERMAL CONDUCTIVITY.') + endif + if (zcp <= 0.0) then + call XABORT('THMSPT: NEGATIVE SALT HEAT CAPACITY.') + endif + +end subroutine THMSPT + +subroutine THMSH(tp, h, zrho, t, impx) + ! return density and temperature given the entalphy + use t_saltdata + + ! character*16 :: salt, compo ! salt formula and composition + real, intent(in) :: h + real, intent(out) :: zrho, t + type(tpdata), intent(in) :: tp ! Tupla with Thermophysical properties + + integer, parameter :: rk=kind(0d0) + integer, parameter :: degree=4 + real(rk) :: poly(degree+1), c1, c2, c3, c4, c5 + complex(rk) :: roots(degree) + logical :: lfail + integer, intent(in) :: impx + ! + if (impx > 3) write(*,*) 'THMSH: Input entalpy h= ',h + ! get the tpdata object for the specific salt + + ! solve polynomial h=CpT => 0 = D*T**4 + C*T**3 + B*T**2 + A*T - h + a = tp%cpA/tp%weight*1000.0 + b = tp%cpB/tp%weight*1000.0 + c = tp%cpC/tp%weight*1000.0 + d = tp%cpD/tp%weight*1000.0 + c1 = real(d, 8) + c2 = real(b, 8) + c3 = real(a, 8) + c4 = real(-h, 8) + c5 = real(c, 8) + poly = [c5, c4, c3, c2, c1] + npoly=degree + do i=degree+1,1,-1 + if (poly(i) /= 0.) exit + npoly=npoly-1 + enddo + if (impx > 3) write(*,*) 'THMSH: Equation ', c1, '*T**4+', c2, '*T**3+', c3, '*T**2+', c4, '*T+', c5 + ! Note: In cmplx_roots_gen the polynomial is of the form poly(1) x^0 + poly(2) x^1 + poly(3) x^2 + ... + call ALROOT(poly,npoly,roots,lfail) + if(lfail) call XABORT('THMSH: foot finding failure.') + if (impx > 3) write(*,*) 'THMSH: roots= ',roots + do i = 1, degree + if (aimag(roots(i)).eq.0.and.real(roots(i)).gt.0) then + t = real(roots(i),4) + exit + endif + end do + zrho = dens(tp,t) + if (impx > 3) write(*,*) 'THMSH: t = ', t, 'zrho = ',zrho +end subroutine THMSH diff --git a/Utilib/src/SAXPY.f b/Utilib/src/SAXPY.f new file mode 100644 index 0000000..af2c3d1 --- /dev/null +++ b/Utilib/src/SAXPY.f @@ -0,0 +1,74 @@ +*DECK SAXPY + SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* constant times a vector plus a vector. Uses unrolled loop for +* increments equal to one. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): Jack Dongarra, linpack, 3/11/78. +* +*Parameters: input +* N number of components in the vector. +* SA constant. +* SX RHS vector. +* INCX increment in RHS vector. +* +*Parameters: output +* SY LHS vector. +* INCY increment in LHS vector. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL SX(N*INCX),SY(N*INCY),SA + INTEGER N,INCX,INCY +*---- +* LOCAL VARIABLES +*---- + INTEGER I,IX,IY,M,MP1 +* + IF(N.LE.0)RETURN + IF (SA .EQ. 0.0) RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +*---- +* CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL TO 1. +*---- + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + SY(IY) = SY(IY) + SA*SX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +*---- +* CODE FOR BOTH INCREMENTS EQUAL TO 1. CLEAN-UP LOOP. +*---- + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + SY(I) = SY(I) + SA*SX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + SY(I) = SY(I) + SA*SX(I) + SY(I + 1) = SY(I + 1) + SA*SX(I + 1) + SY(I + 2) = SY(I + 2) + SA*SX(I + 2) + SY(I + 3) = SY(I + 3) + SA*SX(I + 3) + 50 CONTINUE + RETURN + END diff --git a/Utilib/src/SDOT.f b/Utilib/src/SDOT.f new file mode 100644 index 0000000..c1f8897 --- /dev/null +++ b/Utilib/src/SDOT.f @@ -0,0 +1,76 @@ +*DECK SDOT + REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* forms the dot product of two vectors. Uses unrolled loops for +* increments equal to one. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): Jack Dongarra, linpack, 3/11/78. +* +*Parameters: input +* N number of components in the vectors. +* SX first vector. +* INCX increment in first vector. +* SY second vector. +* INCY increment in second vector. +* +*Parameters: output +* SDOT dot product. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,INCX,INCY + REAL SX(N*INCX),SY(N*INCY) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,IX,IY,M,MP1 + REAL STEMP +* + STEMP = 0.0E0 + SDOT = 0.0E0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +*---- +* CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL TO 1. +*---- + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + STEMP = STEMP + SX(IX)*SY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + SDOT = STEMP + RETURN +*---- +* CODE FOR BOTH INCREMENTS EQUAL TO 1. CLEAN-UP LOOP. +*---- + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + STEMP = STEMP + SX(I)*SY(I) + 30 CONTINUE + IF( N .LT. 5 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + STEMP = STEMP + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) + + * SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4) + 50 CONTINUE + 60 SDOT = STEMP + RETURN + END diff --git a/Utilib/src/SORTIN.f b/Utilib/src/SORTIN.f new file mode 100644 index 0000000..f8f7d9f --- /dev/null +++ b/Utilib/src/SORTIN.f @@ -0,0 +1,49 @@ +*DECK SORTIN + SUBROUTINE SORTIN(N,ARRAY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Sort an array of integers by increasing order using the "Insertion sort" +* method. Based on the C routine available at +* http://linux.wku.edu/~lamonml/algor/sort/insertion.html +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N size of the array. +* +* Parameters: input/output +* ARRAY array of integers. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,ARRAY(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,J,INDEX +* + DO I = 2, N + INDEX = ARRAY(I) + J = I + DO WHILE ((J.GT.1).AND.(ARRAY(J-1).GT.INDEX)) + ARRAY(J) = ARRAY(J-1) + J = J - 1 + ENDDO + ARRAY(J) = INDEX + ENDDO +* + RETURN + END diff --git a/Utilib/src/SORTRE.f b/Utilib/src/SORTRE.f new file mode 100644 index 0000000..645a520 --- /dev/null +++ b/Utilib/src/SORTRE.f @@ -0,0 +1,51 @@ +*DECK SORTRE + SUBROUTINE SORTRE(N,ARRAY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Sort an array of reals by increasing order using the "Insertion sort" +* method. Based on the C routine available at +* http://linux.wku.edu/~lamonml/algor/sort/insertion.html +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N size of the array. +* +*Parameters: input/output +* ARRAY array of reals. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N + REAL ARRAY(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,J + REAL WORK +* + DO I = 2, N + WORK = ARRAY(I) + J = I + DO WHILE ((J.GT.1).AND.(ARRAY(J-1).GT.WORK)) + ARRAY(J) = ARRAY(J-1) + J = J - 1 + ENDDO + ARRAY(J) = WORK + ENDDO +* + RETURN + END diff --git a/Utilib/src/TABEN.f b/Utilib/src/TABEN.f new file mode 100644 index 0000000..0bb9ae8 --- /dev/null +++ b/Utilib/src/TABEN.f @@ -0,0 +1,69 @@ +*DECK TABEN + FUNCTION TABEN(L,X) +* +*----------------------------------------------------------------------- +* +* COMPUTE AN EXPONENTIAL INTEGRAL OF ORDER L. +* +*----------------------------------------------------------- R. ROY ---- +* + IMPLICIT NONE + INTEGER IOUT,NA,NB,NC + CHARACTER NAMSBR*6 + PARAMETER(IOUT=6,NA=6,NB=4,NC=4,NAMSBR='TABEN ') +C---- +C ROUTINE PARAMETERS +C----- + INTEGER L + REAL X +C---- +C FUNCTION TYPE +C---- + REAL TABEN +C---- +C LOCAL PARAMETERS +C---- + INTEGER ITERM + REAL EX,P,R,S +C---- +C DATA +C---- + REAL A(6),B(4),C(4) + SAVE A,B,C + DATA A + > /-.5772156649,.99999193,-.24991055,.05519968, + > -.00976004,.00107857/ + DATA B + > /8.5733287401,18.0590169730,8.634760825,.2677737343/ + DATA C + > /9.5733223454,25.6329561486,21.0996530827,3.9584969228/ + IF(X .LE. 0.)THEN + IF(L .LE. 1)THEN + TABEN= 1.0E20 + ELSE + TABEN=1.0/REAL(L-1) + ENDIF + ELSE + IF (X .LT. 50.) THEN + EX=EXP(-X) + ELSE + EX=0.0 + ENDIF + IF (L .EQ. 0) THEN + TABEN=EX/X + ELSE + IF (X .LE. 1.0) THEN + P=A(1)+X*(A(2)+X*(A(3)+X*(A(4)+X*(A(5)+X*A(6))))) + TABEN=P-LOG(X) + ELSE + R=B(4)+X*(B(3)+X*(B(2)+X*(B(1)+X))) + S=C(4)+X*(C(3)+X*(C(2)+X*(C(1)+X))) + TABEN=R/S*EX/X + ENDIF + DO 100 ITERM=1,L-1 + TABEN=(EX-X*TABEN)/REAL(ITERM) + 100 CONTINUE + ENDIF + ENDIF + RETURN + END diff --git a/Utilib/src/TABKI.f b/Utilib/src/TABKI.f new file mode 100644 index 0000000..47eeb68 --- /dev/null +++ b/Utilib/src/TABKI.f @@ -0,0 +1,84 @@ +*DECK TABKI + FUNCTION TABKI(L,X) +* +*----------------------------------------------------------------------- +* +* COMPUTES BICKLEY FUNCTION FROM QUADRATIC TABLES. +* +* L : ORDER OF THE BICKLEY FUNCTION. +* X : ARGUMENT. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT,MKI1,MKI2,MKI3,MKI4,MKI5 + CHARACTER NAMSBR*6 + PARAMETER(IOUT=6,MKI1=600,MKI2=600,MKI3=600,MKI4=600,MKI5=600, + > NAMSBR='TABKI ') +C---- +C ROUTINE PARAMETERS +C----- + INTEGER L + REAL X +C---- +C FUNCTION TYPE +C---- + REAL TABKI +C---- +C COMMON PARAMETERS +C---- + INTEGER L1,L2,L3,L4,L5 + REAL BI1,PAS1,XLIM1,BI2,PAS2,XLIM2, + > BI3,PAS3,XLIM3,BI4,PAS4,XLIM4, + > BI5,PAS5,XLIM5 + COMMON /BICKL1/BI1(0:MKI1,3),PAS1,XLIM1,L1 + COMMON /BICKL2/BI2(0:MKI2,3),PAS2,XLIM2,L2 + COMMON /BICKL3/BI3(0:MKI3,3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4,3),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:MKI5,3),PAS5,XLIM5,L5 +C---- +C LOCAL PARAMETERS +C---- + INTEGER K + REAL Y + IF(X .LT. 0.0) THEN + WRITE(IOUT,9000) NAMSBR,L,X,NAMSBR,L,0.0 + ENDIF + Y=MAX(X,0.0) + TABKI=0.0 + IF(Y.GT.1.E5) RETURN + IF(L .EQ. 1) THEN + K=MIN(NINT(Y*PAS1),MKI1) + TABKI=BI1(K,1)+Y*(BI1(K,2)+Y*BI1(K,3)) + IF(K .LT. L1 ) THEN + IF(Y .NE. 0.) THEN + TABKI= TABKI + Y*LOG(Y) + ENDIF + ENDIF + ELSE IF(L .EQ. 2) THEN + K=MIN(NINT(Y*PAS2),MKI2) + TABKI=BI2(K,1)+Y*(BI2(K,2)+Y*BI2(K,3)) + IF(K .LT. L2)THEN + IF(Y .NE. 0. ) THEN + TABKI= TABKI - 0.5*Y*Y*LOG(Y) + ENDIF + ENDIF + ELSE IF(L .EQ. 3) THEN + K=MIN(NINT(Y*PAS3),MKI3) + TABKI=BI3(K,1)+Y*(BI3(K,2)+Y*BI3(K,3)) + ELSE IF(L .EQ. 4) THEN + K=MIN(NINT(Y*PAS4),MKI4) + TABKI=BI4(K,1)+Y*(BI4(K,2)+Y*BI4(K,3)) + ELSE IF(L .EQ. 5) THEN + K=MIN(NINT(Y*PAS5),MKI5) + TABKI=BI5(K,1)+Y*(BI5(K,2)+Y*BI5(K,2)) + ELSE + CALL XABORT(NAMSBR//': L > 5 AND L < 1 ARE INVALID') + ENDIF +C---- +C FORMATS +C---- + 9000 FORMAT(1X,' INVALID X IN : ',A6,'(',I1,',',E15.6,')', + > 5X,' REPLACED BY : ',A6,'(',I1,',',E15.6,')') + RETURN + END diff --git a/Utilib/src/UPCKIC.f b/Utilib/src/UPCKIC.f new file mode 100644 index 0000000..4d9f93d --- /dev/null +++ b/Utilib/src/UPCKIC.f @@ -0,0 +1,31 @@ +*DECK UPCKIC + SUBROUTINE UPCKIC(IV,VC,N) +C---- +C UNPACK CHARACTERS FROM AN INTEGER ARRAY 4 AT A TIME +C---- + IMPLICIT NONE + INTEGER NANSI + PARAMETER (NANSI=256) + INTEGER N,I,J,K,II,KK,NUM,ND,NR + INTEGER IV(*) + CHARACTER VC(N)*8 +C---- +C UNPACK ANSI CHARACTER FROM INTEGER VECTOR +C---- + II = 1 + DO 10 I = 1, N + KK = 1 + DO 20 J = 1, 2 + NUM = IV(II) + II = II + 1 + DO 30 K = 1, 4 + ND = NUM/NANSI + NR = NUM -NANSI*ND + NUM = ND + VC(I)(KK:KK)=CHAR(NR) + KK = KK + 1 + 30 CONTINUE + 20 CONTINUE + 10 CONTINUE + RETURN + END diff --git a/Utilib/src/XDRCAS.f b/Utilib/src/XDRCAS.f new file mode 100644 index 0000000..eb686a9 --- /dev/null +++ b/Utilib/src/XDRCAS.f @@ -0,0 +1,52 @@ +*DECK XDRCAS + SUBROUTINE XDRCAS(DIR,TEXT) +* +*----------------------------------------------------------------------- +* +* CONVERT A LOWER-CASE CHARACTER VARIABLE TO UPPER CASE OR +* UPPER CASE CHARACTER VARIABLE TO LOWER-CASE +* +* INPUT/OUTPUT VARIABLE: +* DIR : DIRECTION OF CONVERSION +* ='LOWTOUP' FOR LOWER TO UPPER +* ='UPTOLOW' FOR UPPER TO LOWER +* TEXT : CHARACTER VARIABLE TO BE CONVERTED. +* +*----------------------------------------------------------------------- +* + CHARACTER DIR*(*),TEXT*(*) +C---- +C LOCAL PARAMETERS +C---- + PARAMETER (NCAR=26) + INTEGER LENTEX,ITEX,ICAR + CHARACTER LOWCAS(NCAR)*1,UPCAS(NCAR)*1 + SAVE LOWCAS,UPCAS + DATA LOWCAS /'a','b','c','d','e','f','g','h','i','j','k','l','m', + > 'n','o','p','q','r','s','t','u','v','w','x','y','z'/ + DATA UPCAS /'A','B','C','D','E','F','G','H','I','J','K','L','M', + > 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ + LENTEX=LEN(TEXT) + IF(DIR.EQ.'LOWTOUP') THEN + DO 100 ITEX=1,LENTEX + DO 110 ICAR=1,NCAR + IF(TEXT(ITEX:ITEX).EQ.LOWCAS(ICAR)) THEN + TEXT(ITEX:ITEX)=UPCAS(ICAR) + GO TO 115 + ENDIF + 110 CONTINUE + 115 CONTINUE + 100 CONTINUE + ELSE IF (DIR.EQ.'UPTOLOW') THEN + DO 200 ITEX=1,LENTEX + DO 210 ICAR=1,NCAR + IF(TEXT(ITEX:ITEX).EQ.UPCAS(ICAR)) THEN + TEXT(ITEX:ITEX)=LOWCAS(ICAR) + GO TO 215 + ENDIF + 210 CONTINUE + 215 CONTINUE + 200 CONTINUE + ENDIF + RETURN + END diff --git a/Utilib/src/XDRCST.f b/Utilib/src/XDRCST.f new file mode 100644 index 0000000..33ddad6 --- /dev/null +++ b/Utilib/src/XDRCST.f @@ -0,0 +1,197 @@ +*DECK XDRCST + FUNCTION XDRCST(CSTNAM,CSTUNT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To return the physical constants in the required units or get constant +* for converting between units. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* +*Author(s): G. Marleau. +* +*Parameters: input +* CSTNAM constant name or initial units for conversion where +* \begin{itemize} +* \item \moc{CSTNAM}=\moc{Avogadro} is for Avogadro number +* with units in N/moles; +* \item \moc{CSTNAM}=\moc{Plank} is for Plank constant +* with units in J$\times$s, MeV$\times$s or eV$\times$s; +* \item \moc{CSTNAM}=\moc{Boltzmann} is for Boltzmann constant +* with units in J/K, MeV/K or eV/K ; +* \item \moc{CSTNAM}=\moc{Neutron mass} is for neutron mass +* with units in kg, amu, MeV or eV; +* \item \moc{CSTNAM}=\moc{Proton mass} is for proton mass +* with units in kg, amu, MeV or eV; +* \item \moc{CSTNAM}=\moc{kg} is the factor to transform kg +* into amu, MeV, eV or J; +* \item \moc{CSTNAM}=\moc{amu} is the factor to transform amu +* into kg, MeV, eV or J; +* \item \moc{CSTNAM}=\moc{eV} is the factor to transform eV +* into J or K; +* \item \moc{CSTNAM}=\moc{K} is the factor to transform K +* into J or eV; +* \item \moc{CSTNAM}=\moc{J} is the factor to transform J +* into eV or K; +* \item \moc{CSTNAM}=\moc{Pi} is for $\pi$ +* without units. +* \end{itemize} +* CSTUNT units for the constant or final units as described for +* \moc{CSTNAM}. +* +*Parameters: input +* XDRCST numerical value of the constant in required unit. +* +*References: +* Peter J. Mohr and Barry N. Taylor, CODATA Recommended Values of the +* Fundamental Physical Constants: 2002. (to be published) +* http://physics.nist.gov/constants +* Last visit: September 04, 2004 +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + CHARACTER CSTNAM*(*) + CHARACTER CSTUNT*(*) + DOUBLE PRECISION XDRCST +*---- +* Parameters +*---- + INTEGER IOUT + PARAMETER (IOUT=6) + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='XDRCST') + DOUBLE PRECISION EVJOULE,AMUKG,SPEEDL + PARAMETER (EVJOULE=1.60217653D-19,AMUKG=1.66053886D-27, + > SPEEDL=2.99792458D+08) + DOUBLE PRECISION PI + PARAMETER (PI=3.14159265358979323846D+00) + CHARACTER CSTNT*12 + CHARACTER CSTUT*12 +*---- +* Various constants +*---- + XDRCST=0.0D0 + CSTNT=CSTNAM + CSTUT=CSTUNT + IF(INDEX(CSTNT,'Avogadro') .NE. 0) THEN + XDRCST=6.0221415D+23 + IF(INDEX(CSTUT,'N/moles') .EQ. 0) THEN + CALL XABORT(NAMSBR//': Invalid units for Avogadro number') + ENDIF + ELSE IF(INDEX(CSTNT,'Plank') .NE. 0) THEN + XDRCST=6.6260693D-34 + IF(INDEX(CSTUT,'MeV s') .NE. 0) THEN + XDRCST=1.0D-06*XDRCST/EVJOULE + ELSE IF(INDEX(CSTUT,'eV s') .NE. 0) THEN + XDRCST=XDRCST/EVJOULE + ELSE IF(INDEX(CSTUT,'J s') .EQ. 0) THEN + CALL XABORT(NAMSBR//': Invalid units for Plank constant') + ENDIF + ELSE IF(INDEX(CSTNT,'Boltzmann') .NE. 0) THEN + XDRCST=1.3806505D-23 + IF(INDEX(CSTUT,'MeV/K') .NE. 0) THEN + XDRCST=1.0D-06*XDRCST/EVJOULE + ELSE IF(INDEX(CSTUT,'eV/K') .NE. 0) THEN + XDRCST=XDRCST/EVJOULE + ELSE IF(INDEX(CSTUT,'J/K') .EQ. 0) THEN + CALL XABORT(NAMSBR//': Invalid units for Boltzmann constant') + ENDIF +*---- +* Various mass +*---- + ELSE IF(INDEX(CSTNT,'Neutron mass') .NE. 0) THEN + XDRCST=1.67492728D-27 + IF(INDEX(CSTUT,'amu') .NE. 0) THEN + XDRCST=XDRCST/AMUKG + ELSE IF(INDEX(CSTUT,'MeV') .NE. 0) THEN + XDRCST=1.0D-06*XDRCST*SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'eV') .NE. 0) THEN + XDRCST=XDRCST*SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'kg') .EQ. 0) THEN + CALL XABORT(NAMSBR//': Invalid units for neutron mass') + ENDIF + ELSE IF(INDEX(CSTNT,'Proton mass') .NE. 0) THEN + XDRCST=1.67262171D-27 + IF(INDEX(CSTUT,'amu') .NE. 0) THEN + XDRCST=XDRCST/AMUKG + ELSE IF(INDEX(CSTUT,'MeV') .NE. 0) THEN + XDRCST=1.0D-06*XDRCST*SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'eV') .NE. 0) THEN + XDRCST=XDRCST*SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'kg') .EQ. 0) THEN + CALL XABORT(NAMSBR//': Invalid units for neutron mass') + ENDIF +*---- +* Various mass energy conversion units +*---- + ELSE IF(INDEX(CSTNT,'kg') .NE. 0) THEN + IF(INDEX(CSTUT,'amu') .NE. 0) THEN + XDRCST=1.0D0/AMUKG + ELSE IF(INDEX(CSTUT,'MeV') .NE. 0) THEN + XDRCST=1.0D-06*SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'eV') .NE. 0) THEN + XDRCST=SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'J') .NE. 0) THEN + XDRCST=SPEEDL*SPEEDL + ELSE + CALL XABORT(NAMSBR//': No relations between '//CSTNT// + > ' and '//CSTUT) + ENDIF + ELSE IF(INDEX(CSTNT,'amu') .NE. 0) THEN + IF(INDEX(CSTUT,'kg') .NE. 0) THEN + XDRCST=AMUKG + ELSE IF(INDEX(CSTUT,'MeV') .NE. 0) THEN + XDRCST=1.0D-06*AMUKG*SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'eV') .NE. 0) THEN + XDRCST=AMUKG*SPEEDL*SPEEDL/EVJOULE + ELSE IF(INDEX(CSTUT,'J') .NE. 0) THEN + XDRCST=AMUKG*SPEEDL*SPEEDL + ELSE + CALL XABORT(NAMSBR//': No relations between '//CSTNT// + > ' and '//CSTUT) + ENDIF + ELSE IF(INDEX(CSTNT,'eV') .NE. 0) THEN + IF(INDEX(CSTUT,'J') .NE. 0) THEN + XDRCST=EVJOULE + ELSE IF(INDEX(CSTUT,'K') .NE. 0) THEN + XDRCST=EVJOULE/1.3806505D-23 + ELSE + CALL XABORT(NAMSBR//': No relations between '//CSTNT// + > ' and '//CSTUT) + ENDIF + ELSE IF(INDEX(CSTNT,'K') .NE. 0) THEN + IF(INDEX(CSTUT,'J') .NE. 0) THEN + XDRCST=1.3806505D-23 + ELSE IF(INDEX(CSTUT,'eV') .NE. 0) THEN + XDRCST=1.3806505D-23/EVJOULE + ELSE + CALL XABORT(NAMSBR//': No relations between '//CSTNT// + > ' and '//CSTUT) + ENDIF + ELSE IF(INDEX(CSTNT,'J') .NE. 0) THEN + IF(INDEX(CSTUT,'eV') .NE. 0) THEN + XDRCST=1.0D0/EVJOULE + ELSE IF(INDEX(CSTUT,'K') .NE. 0) THEN + XDRCST=1.0D0/1.3806505D-23 + ELSE + CALL XABORT(NAMSBR//': No relations between '//CSTNT// + > ' and '//CSTUT) + ENDIF + ELSE IF(INDEX(CSTNT,'Pi') .NE. 0) THEN + IF(CSTUT .EQ. ' ') THEN + XDRCST=PI + ELSE + CALL XABORT(NAMSBR//': No units for Pi ') + ENDIF + ELSE + CALL XABORT(NAMSBR//': '//CSTNT// + > ' is an invalid constant or unit') + ENDIF + RETURN + END diff --git a/Utilib/src/XDRSDB.f b/Utilib/src/XDRSDB.f new file mode 100644 index 0000000..345b3f1 --- /dev/null +++ b/Utilib/src/XDRSDB.f @@ -0,0 +1,51 @@ +*DECK XDRSDB + SUBROUTINE XDRSDB(NBELEM,RVECT,DBVECT,KDIR) +C +C--------------------------- XDRSDB --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C +C NAME : XDRSDB +C FUNCTION : DOUBLE PRECISION TO/FROM SIMPLE PRECISION +C DATE : 20-02-1987 +C AUTHOR : G.MARLEAU +C +C 2- INPUT AND OUTPUT PARAMETERS: +C +C NBELEM : NUMBER OF WORDS TO TRANSLATE +C RVECT : SIMPLE PRECISION VECTOR - RVECT(NBELEM) +C DBVECT : DOUBLE PRECISION VECTOR - DBRVECT(NBELEM) +C KDIR : DIRECTION OF TRANSLATION +C : KDIR = 1 FROM DOUBLE TO SIMPLE PRECISION +C : KDIR = 2 FROM SIMPLE TO DOUBLE PRECISION +C +C--------------------------- XDRSDB -------------------------------- +C + CHARACTER CERROR*4 + INTEGER NBELEM,KDIR + REAL RVECT(*) + DOUBLE PRECISION DBVECT(*) + IF(KDIR.EQ.1) THEN +C------ +C FROM DOUBLE TO SIMPLE PRECISION +C------ + DO 100 IELEM=1,NBELEM + RVECT(IELEM)=REAL(DBVECT(IELEM)) + 100 CONTINUE + ELSE IF(KDIR.EQ.2) THEN +C------ +C FROM SIMPLE TO DOUBLE PRECISION +C------ + DO 200 IELEM=NBELEM,1,-1 + DBVECT(IELEM)=DBLE(RVECT(IELEM)) + 200 CONTINUE + ELSE +C------ +C INVALID VALUE FOR KDIR +C------ + WRITE(CERROR,'(I4)') KDIR + CALL XABORT('XDRSDB: ONLY KDIR=1 AND KDIR=2 ALLOWED; KDIR=' + > //CERROR//' FOUND') + ENDIF + RETURN + END diff --git a/Utilib/src/b23.c b/Utilib/src/b23.c new file mode 100644 index 0000000..7b4b56f --- /dev/null +++ b/Utilib/src/b23.c @@ -0,0 +1,40 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2005 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#define FREESTEAM_BUILDING_LIB +#include "b23.h" + +#include <math.h> + +const double B23_N[6] = { 0, 0.34805185628969E+03, -0.11671859879975E+01 + , 0.10192970039326E-02, 0.57254459862746E+03, 0.13918839778870E+02 +}; + +const double B23_PSTAR = 1e6; + +double freesteam_b23_p_T(double T){ +#define theta T + return (B23_N[1] + B23_N[2] * theta + B23_N[3] * SQ(theta)) * B23_PSTAR; +#undef theta +} + +double freesteam_b23_T_p(double p){ + double pi = p / B23_PSTAR; + return B23_N[4] + sqrt((pi - B23_N[5])/B23_N[3]) /* * 1{K} */; +} diff --git a/Utilib/src/b23.h b/Utilib/src/b23.h new file mode 100644 index 0000000..afe61e1 --- /dev/null +++ b/Utilib/src/b23.h @@ -0,0 +1,28 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2005 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#ifndef FREESTEAM_B23_H +#define FREESTEAM_B23_H + +#include "common.h" + +FREESTEAM_DLL double freesteam_b23_p_T(double T); +FREESTEAM_DLL double freesteam_b23_T_p(double p); + +#endif + diff --git a/Utilib/src/backwards.c b/Utilib/src/backwards.c new file mode 100644 index 0000000..0e3e352 --- /dev/null +++ b/Utilib/src/backwards.c @@ -0,0 +1,841 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*//** @file + Backwards equations for IAPWS-IF97. Facilitate calculation of + properties in terms of (p,h) without requiring any iteration. + + TODO add boundary curves? + TODO add more equations for (p,s) calculation? + + Numerical data for T(p,h) and v(p,h) correlations was extracted from + the Matlab version 2.6 of Xsteam by by Magnus Holmgren. +*/ + +#define FREESTEAM_BUILDING_LIB +#include "backwards.h" + +#include "backwards_impl.h" +#include <math.h> + +/*------------------------------------------------------------------------------ + REGION 1 BACKWARDS EQUATION T(P,H) +*/ + +typedef struct{ + int I, J; + double n; +} BackwardsData; + +/** + Source: IAPWS-IF97-REV section 5.2.1 +*/ +BackwardsData REGION1_TPH_DATA[] = { + {0, 0, -238.72489924521} + ,{0, 1, 404.21188637945} + ,{0, 2, 113.49746881718} + ,{0, 6, -5.8457616048039} + ,{0, 22, -1.528548241314E-04} + ,{0, 32, -1.0866707695377E-06} + ,{1, 0, -13.391744872602} + ,{1, 1, 43.211039183559} + ,{1, 2, -54.010067170506} + ,{1, 3, 30.535892203916} + ,{1, 4, -6.5964749423638} + ,{1,10, 9.3965400878363E-03} + ,{1,32, 1.157364750534E-07} + ,{2,10,-2.5858641282073E-05} + ,{2,32,-4.0644363084799E-09} + ,{3,10,6.6456186191635E-08} + ,{3,32,8.0670734103027E-11} + ,{4,32,-9.3477771213947E-13} + ,{5,32,5.8265442020601E-15} + ,{6,32,-1.5020185953503E-17} +}; + +const unsigned REGION1_TPH_MAX = sizeof(REGION1_TPH_DATA)/sizeof(BackwardsData); + +const double REGION1_TPH_HSTAR = 2500e3; /* J/kg */ +const double REGION1_TPH_PSTAR = 1e6; /* Pa */ + +/** + Backward equation for temperature in terms of pressure and enthalpy + in IAPWS-IF97 Region 1. Source: IAPWS-IF97-Rev section 5.2.1. + + @param p pressure in Pa + @param h enthalpy in J/kg + @return temperature in K +*/ +double freesteam_region1_T_ph(double p, double h){ + double pi = p / REGION1_TPH_PSTAR; + double e1 = 1. + (h / REGION1_TPH_HSTAR); + unsigned i; + BackwardsData *d; + double sum = 0; + for(i=0, d = REGION1_TPH_DATA; i<REGION1_TPH_MAX; ++i, ++d){ + /* TODO some optimisations are possible here with pow(pi,...) */ + sum += d->n * ipow(pi,d->I) * ipow(e1, d->J); + } + return sum /* * REGION1_TPH_TSTAR = 1. */; +} + + +/*------------------------------------------------------------------------------ + REGION 2 BACKWARDS EQUATION T(P,H) +*/ + +/* sub-region 2a */ +BackwardsData REGION2A_TPH_DATA[] = { + {0, 0, 1089.8952318288} + ,{0, 1, 849.51654495535} + ,{0, 2, -107.81748091826} + ,{0, 3, 33.153654801263} + ,{0, 7, -7.4232016790248} + ,{0, 20, 11.765048724356} + ,{1, 0, 1.844574935579} + ,{1, 1, -4.1792700549624} + ,{1, 2, 6.2478196935812} + ,{1, 3, -17.344563108114} + ,{1, 7, -200.58176862096} + ,{1, 9, 271.96065473796} + ,{1, 11, -455.11318285818} + ,{1, 18, 3091.9688604755} + ,{1, 44, 252266.40357872} + ,{2, 0, -6.1707422868339E-03} + ,{2, 2, -0.31078046629583} + ,{2, 7, 11.670873077107} + ,{2, 36, 128127984.04046} + ,{2, 38, -985549096.23276} + ,{2, 40, 2822454697.3002} + ,{2, 42, -3594897141.0703} + ,{2, 44, 1722734991.3197} + ,{3, 24, -13551.334240775} + ,{3, 44, 12848734.66465} + ,{4, 12, 1.3865724283226} + ,{4, 32, 235988.32556514} + ,{4, 44, -13105236.545054} + ,{5, 32, 7399.9835474766} + ,{5, 36, -551966.9703006} + ,{5, 42, 3715408.5996233} + ,{6, 34, 19127.72923966} + ,{6, 44, -415351.64835634} + ,{7, 28, -62.459855192507} + +}; + +const unsigned REGION2A_TPH_MAX = sizeof(REGION2A_TPH_DATA)/sizeof(BackwardsData); + +/* sub-region 2b */ + +BackwardsData REGION2B_TPH_DATA[] = { + {0, 0, 1489.5041079516} + ,{0, 1, 743.07798314034} + ,{0, 2, -97.708318797837} + ,{0, 12, 2.4742464705674} + ,{0, 18, -0.63281320016026} + ,{0, 24, 1.1385952129658} + ,{0, 28, -0.47811863648625} + ,{0, 40, 8.5208123431544E-03} + ,{1, 0, 0.93747147377932} + ,{1, 2, 3.3593118604916} + ,{1, 6, 3.3809355601454} + ,{1, 12, 0.16844539671904} + ,{1, 18, 0.73875745236695} + ,{1, 24, -0.47128737436186} + ,{1, 28, 0.15020273139707} + ,{1, 40, -0.002176411421975} + ,{2, 2, -0.021810755324761} + ,{2, 8, -0.10829784403677} + ,{2, 18, -0.046333324635812} + ,{2, 40, 7.1280351959551E-05} + ,{3, 1, 1.1032831789999E-04} + ,{3, 2, 1.8955248387902E-04} + ,{3, 12, 3.0891541160537E-03} + ,{3, 24, 1.3555504554949E-03} + ,{4, 2, 2.8640237477456E-07} + ,{4, 12, -1.0779857357512E-05} + ,{4, 18, -7.6462712454814E-05} + ,{4, 24, 1.4052392818316E-05} + ,{4, 28, -3.1083814331434E-05} + ,{4, 40, -1.0302738212103E-06} + ,{5, 18, 2.821728163504E-07} + ,{5, 24, 1.2704902271945E-06} + ,{5, 40, 7.3803353468292E-08} + ,{6, 28, -1.1030139238909E-08} + ,{7, 2, -8.1456365207833E-14} + ,{7, 28, -2.5180545682962E-11} + ,{9, 1, -1.7565233969407E-18} + ,{9, 40, 8.6934156344163E-15} + +}; + +const unsigned REGION2B_TPH_MAX = sizeof(REGION2B_TPH_DATA)/sizeof(BackwardsData); + +/* sub-region 2c */ +BackwardsData REGION2C_TPH_DATA[] ={ + {-7, 0, -3236839855524.2} + ,{-7, 4, 7326335090218.1} + ,{-6, 0, 358250899454.47} + ,{-6, 2, -583401318515.9} + ,{-5, 0, -10783068217.47} + ,{-5, 2, 20825544563.171} + ,{-2, 0, 610747.83564516} + ,{-2, 1, 859777.2253558} + ,{-1, 0, -25745.72360417} + ,{-1, 2, 31081.088422714} + ,{0, 0, 1208.2315865936} + ,{0, 1, 482.19755109255} + ,{1, 4, 3.7966001272486} + ,{1, 8, -10.842984880077} + ,{2, 4, -0.04536417267666} + ,{6, 0, 1.4559115658698E-13} + ,{6, 1, 1.126159740723E-12} + ,{6, 4, -1.7804982240686E-11} + ,{6, 10, 1.2324579690832E-07} + ,{6, 12, -1.1606921130984E-06} + ,{6, 16, 2.7846367088554E-05} + ,{6, 20, -5.9270038474176E-04} + ,{6, 22, 1.2918582991878E-03} + +}; + +const unsigned REGION2C_TPH_MAX = sizeof(REGION2C_TPH_DATA)/sizeof(BackwardsData); + +const double REGION2AB_P = 4.e6; /* Pa */ + +const double REGION2_HSTAR = 2000e3; +const double REGION2_PSTAR = 1.e6; + +/* REGION2_B2BC_PH defined in backwards_impl.h */ + +/** + Backward equation for temperature in terms of pressure and enthalpy + in IAPWS-IF97 Region 2 (composed of sub-regions 2a, 2b, 2c). + Source: IAPWS-IF97-Rev section 5.2.1. + + @param p pressure in Pa + @param h enthalpy in J/kg + @return temperature in K +*/ +double freesteam_region2_T_ph(double p, double h){ + double eta = h / REGION2_HSTAR; + double pi = p / REGION2_PSTAR; + double pi1, eta1; + BackwardsData *d; + unsigned i, n; + double sum = 0; + if(p < REGION2AB_P){ + pi1 = pi; eta1 = eta - 2.1; + d = REGION2A_TPH_DATA; + n = REGION2A_TPH_MAX; + }else{ + if(REGION2_B2BC_PH(p,h) < 0.){ + pi1 = pi - 2.; eta1 = eta - 2.6; + d = REGION2B_TPH_DATA; + n = REGION2B_TPH_MAX; + }else{ + pi1 = pi + 25.; eta1 = eta - 1.8; + d = REGION2C_TPH_DATA; + n = REGION2C_TPH_MAX; + } + } + + for(i = 0; i<n; ++i, ++d){ + sum += d->n * ipow(pi1, d->I) * ipow(eta1, d->J); + } + + return sum /* * REGION2_TSTAR = 1 K */; +} + + +/*------------------------------------------------------------------------------ + REGION 3 BACKWARDS EQUATION T(P,H) +*/ + +/* sub-region 3a */ +BackwardsData REGION3A_TPH_DATA[] = { + {-12, 0, -1.33645667811215E-07} + ,{-12, 1, 4.55912656802978E-06} + ,{-12, 2, -1.46294640700979E-05} + ,{-12, 6, 6.3934131297008E-03} + ,{-12, 14, 372.783927268847} + ,{-12, 16, -7186.54377460447} + ,{-12, 20, 573494.7521034} + ,{-12, 22, -2675693.29111439} + ,{-10, 1, -3.34066283302614E-05} + ,{-10, 5, -2.45479214069597E-02} + ,{-10, 12, 47.8087847764996} + ,{-8, 0, 7.64664131818904E-06} + ,{-8, 2, 1.28350627676972E-03} + ,{-8, 4, 1.71219081377331E-02} + ,{-8, 10, -8.51007304583213} + ,{-5, 2, -1.36513461629781E-02} + ,{-3, 0, -3.84460997596657E-06} + ,{-2, 1, 3.37423807911655E-03} + ,{-2, 3, -0.551624873066791} + ,{-2, 4, 0.72920227710747} + ,{-1, 0, -9.92522757376041E-03} + ,{-1, 2, -0.119308831407288} + ,{0, 0, 0.793929190615421} + ,{0, 1, 0.454270731799386} + ,{1, 1, 0.20999859125991} + ,{3, 0, -6.42109823904738E-03} + ,{3, 1, -0.023515586860454} + ,{4, 0, 2.52233108341612E-03} + ,{4, 3, -7.64885133368119E-03} + ,{10, 4, 1.36176427574291E-02} + ,{12, 5, -1.33027883575669E-02} +}; + +const unsigned REGION3A_TPH_MAX = sizeof(REGION3A_TPH_DATA)/sizeof(BackwardsData); + +BackwardsData REGION3B_TPH_DATA[] = { + {-12, 0, 3.2325457364492E-05} + ,{-12, 1, -1.27575556587181E-04} + ,{-10, 0, -4.75851877356068E-04} + ,{-10, 1, 1.56183014181602E-03} + ,{-10, 5, 0.105724860113781} + ,{-10, 10, -85.8514221132534} + ,{-10, 12, 724.140095480911} + ,{-8, 0, 2.96475810273257E-03} + ,{-8, 1, -5.92721983365988E-03} + ,{-8, 2, -1.26305422818666E-02} + ,{-8, 4, -0.115716196364853} + ,{-8, 10, 84.9000969739595} + ,{-6, 0, -1.08602260086615E-02} + ,{-6, 1, 1.54304475328851E-02} + ,{-6, 2, 7.50455441524466E-02} + ,{-4, 0, 2.52520973612982E-02} + ,{-4, 1, -6.02507901232996E-02} + ,{-3, 5, -3.07622221350501} + ,{-2, 0, -5.74011959864879E-02} + ,{-2, 4, 5.03471360939849} + ,{-1, 2, -0.925081888584834} + ,{-1, 4, 3.91733882917546} + ,{-1, 6, -77.314600713019} + ,{-1, 10, 9493.08762098587} + ,{-1, 14, -1410437.19679409} + ,{-1, 16, 8491662.30819026} + ,{0, 0, 0.861095729446704} + ,{0, 2, 0.32334644281172} + ,{1, 1, 0.873281936020439} + ,{3, 1, -0.436653048526683} + ,{5, 1, 0.286596714529479} + ,{6, 1, -0.131778331276228} + ,{8, 1, 6.76682064330275E-03} +}; + +const unsigned REGION3B_TPH_MAX = sizeof(REGION3B_TPH_DATA)/sizeof(BackwardsData); + +/* REGION3_B3AB_PH(P,H) boundary test declared in backwards_impl.h */ + +const double REGION3A_TPH_HSTAR = 2300e3; +const double REGION3A_TPH_PSTAR = 100.e6; +const double REGION3A_TPH_TSTAR = 760; + +const double REGION3B_TPH_HSTAR = 2800e3; +const double REGION3B_TPH_PSTAR = 100.e6; +const double REGION3B_TPH_TSTAR = 860; + +/** + Backward equation for temperature in terms of pressure and enthalpy + in IAPWS-IF97 Region 3 (composed of sub-regions 3a, 3b). + + Source: IAPWS 'Revised Supplementary Release on Backward Equations for the Functions + T(p,h), v(p,h) and T(p,s), v(p,s) for Region 3 of the IAPWS Industrial + Formulation 1997 for the Thermodynamic Properties of Water and Steam', 2004. + + @param p pressure in Pa + @param h enthalpy in J/kg + @return temperature in K +*/ +double freesteam_region3_T_ph(double p, double h){ + double pi1, eta1; + double Tstar; + BackwardsData *d; + unsigned i, n; + double sum = 0; + if(REGION3_B3AB_PH(p,h) <= 0.){ + /* sub-region 3a */ + pi1 = p/REGION3A_TPH_PSTAR + 0.240; eta1 = h/REGION3A_TPH_HSTAR - 0.615; + d = REGION3A_TPH_DATA; + n = REGION3A_TPH_MAX; + Tstar = REGION3A_TPH_TSTAR; + }else{ + /* sub-region 3b */ + pi1 = p/REGION3B_TPH_PSTAR + 0.298; eta1 = h/REGION3B_TPH_HSTAR - 0.720; + d = REGION3B_TPH_DATA; + n = REGION3B_TPH_MAX; + Tstar = REGION3B_TPH_TSTAR; + } + + for(i = 0; i<n; ++i, ++d){ + sum += d->n * ipow(pi1, d->I) * ipow(eta1, d->J); + } + + return sum * Tstar; +} + + +/*------------------------------------------------------------------------------ + REGION 3 V(P,H) +*/ + +BackwardsData REGION3A_VPH_DATA[] = { + {-12, 6, 5.29944062966028E-03} + ,{-12, 8, -0.170099690234461} + ,{-12, 12, 11.1323814312927} + ,{-12, 18, -2178.98123145125} + ,{-10, 4, -5.06061827980875E-04} + ,{-10, 7, 0.556495239685324} + ,{-10, 10, -9.43672726094016} + ,{-8, 5, -0.297856807561527} + ,{-8, 12, 93.9353943717186} + ,{-6, 3, 1.92944939465981E-02} + ,{-6, 4, 0.421740664704763} + ,{-6, 22, -3689141.2628233} + ,{-4, 2, -7.37566847600639E-03} + ,{-4, 3, -0.354753242424366} + ,{-3, 7, -1.99768169338727} + ,{-2, 3, 1.15456297059049} + ,{-2, 16, 5683.6687581596} + ,{-1, 0, 8.08169540124668E-03} + ,{-1, 1, 0.172416341519307} + ,{-1, 2, 1.04270175292927} + ,{-1, 3, -0.297691372792847} + ,{0, 0, 0.560394465163593} + ,{0, 1, 0.275234661176914} + ,{1, 0, -0.148347894866012} + ,{1, 1, -6.51142513478515E-02} + ,{1, 2, -2.92468715386302} + ,{2, 0, 6.64876096952665E-02} + ,{2, 2, 3.52335014263844} + ,{3, 0, -1.46340792313332E-02} + ,{4, 2, -2.24503486668184} + ,{5, 2, 1.10533464706142} + ,{8, 2, -4.08757344495612E-02} +}; + +const unsigned REGION3A_VPH_MAX = sizeof(REGION3A_VPH_DATA)/sizeof(BackwardsData); + +BackwardsData REGION3B_VPH_DATA[] = { + {-12, 0, -2.25196934336318E-09} + ,{-12, 1, 1.40674363313486E-08} + ,{-8, 0, 2.3378408528056E-06} + ,{-8, 1, -3.31833715229001E-05} + ,{-8, 3, 1.07956778514318E-03} + ,{-8, 6, -0.271382067378863} + ,{-8, 7, 1.07202262490333} + ,{-8, 8, -0.853821329075382} + ,{-6, 0, -2.15214194340526E-05} + ,{-6, 1, 7.6965608822273E-04} + ,{-6, 2, -4.31136580433864E-03} + ,{-6, 5, 0.453342167309331} + ,{-6, 6, -0.507749535873652} + ,{-6, 10, -100.475154528389} + ,{-4, 3, -0.219201924648793} + ,{-4, 6, -3.21087965668917} + ,{-4, 10, 607.567815637771} + ,{-3, 0, 5.57686450685932E-04} + ,{-3, 2, 0.18749904002955} + ,{-2, 1, 9.05368030448107E-03} + ,{-2, 2, 0.285417173048685} + ,{-1, 0, 3.29924030996098E-02} + ,{-1, 1, 0.239897419685483} + ,{-1, 4, 4.82754995951394} + ,{-1, 5, -11.8035753702231} + ,{0, 0, 0.169490044091791} + ,{1, 0, -1.79967222507787E-02} + ,{1, 1, 3.71810116332674E-02} + ,{2, 2, -5.36288335065096E-02} + ,{2, 6, 1.6069710109252} +}; + +const unsigned REGION3B_VPH_MAX = sizeof(REGION3B_VPH_DATA)/sizeof(BackwardsData); + +const double REGION3A_VPH_HSTAR = 2100e3; /* J/kg */ +const double REGION3A_VPH_PSTAR = 100.e6; /* Pa */ +const double REGION3A_VPH_VSTAR = 0.0028; /* m3/kg */ + +const double REGION3B_VPH_HSTAR = 2800e3; +const double REGION3B_VPH_PSTAR = 100.e6; +const double REGION3B_VPH_VSTAR = 0.0088; + +/** + Backward equation for specific volume in terms of pressure and enthalpy + in IAPWS-IF97 Region 3 (composed of sub-regions 3a, 3b). + + Source: IAPWS 'Revised Supplementary Release on Backward Equations for the Functions + T(p,h), v(p,h) and T(p,s), v(p,s) for Region 3 of the IAPWS Industrial + Formulation 1997 for the Thermodynamic Properties of Water and Steam', 2004. + + @param p pressure in Pa + @param h enthalpy in J/kg + @return temperature in K +*/ +double freesteam_region3_v_ph(double p, double h){ + double pi1, eta1; + BackwardsData *d; + unsigned i, n; + double sum = 0; + double vstar; + if(REGION3_B3AB_PH(p,h) <= 0.){ + /* sub-region 3a */ + pi1 = p/REGION3A_VPH_PSTAR + 0.128; eta1 = h/REGION3A_VPH_HSTAR - 0.727; + d = REGION3A_VPH_DATA; + n = REGION3A_VPH_MAX; + vstar = REGION3A_VPH_VSTAR; + }else{ + /* sub-region 3b */ + pi1 = p/REGION3B_VPH_PSTAR + 0.0661; eta1 = h/REGION3B_VPH_HSTAR - 0.720; + d = REGION3B_VPH_DATA; + n = REGION3B_VPH_MAX; + vstar = REGION3B_VPH_VSTAR; + } + + for(i = 0; i<n; ++i, ++d){ + sum += d->n * ipow(pi1, d->I) * ipow(eta1, d->J); + } + + return sum * vstar; +} + +/*------------------------------------------------------------------------------ + REGION 3 PSAT(H) BOUNDARY +*/ + +BackwardsData REGION3_PSATH_DATA[] = { + { 0, 0, 0.600073641753024} + ,{1, 1, -0.936203654849857e1} + ,{1, 3, 0.246590798594147e2} + ,{1, 4, -0.107014222858224e3} + ,{1, 36, -0.915821315805768e14} + ,{5, 3, -0.862332011700662e4} + ,{7, 0, -0.235837344740032e2} + ,{8, 24, 0.252304969384128e18} + ,{14, 16, -0.389718771997719e19} + ,{20, 16, -0.333775713645296e23} + ,{22, 3, 0.356499469636328e11} + ,{24, 18, -0.148547544720641e27} + ,{28, 8, 0.330611514838798e19} + ,{36, 24, 0.813641294467829e38} +}; + +const unsigned REGION3_PSATH_MAX = sizeof(REGION3_PSATH_DATA)/sizeof(BackwardsData); + +const double REGION3_PSATH_HSTAR = 2600e3; +const double REGION3_PSATH_PSTAR = 22.e6; + +double freesteam_region3_psat_h(double h){ + BackwardsData *d, *e = REGION3_PSATH_DATA + REGION3_PSATH_MAX; + double eta = h / REGION3_PSATH_HSTAR; + double eta1 = eta - 1.02; + double eta2 = eta - 0.608; + double sum = 0; + for(d = REGION3_PSATH_DATA; d<e; ++d){ + sum += d->n * ipow(eta1, d->I) * ipow(eta2, d->J); + } + return sum * REGION3_PSATH_PSTAR; +} + +/*------------------------------------------------------------------------------ + REGION 3 PSAT(S) BOUNDARY +*/ + +BackwardsData REGION3_PSATS_DATA[] = { + { 0, 0, 0.639767553612785} + , {1, 1, -0.129727445396014e2} + , {1, 32, -0.224595125848403e16} + , {4, 7, 0.177466741801846e7} + , {12, 4, 0.717079349571538e10} + , {12, 14, -0.378829107169011e18} + , {16, 36, -0.955586736431328e35} + , {24, 10, 0.187269814676188e24} + , {28, 0, 0.119254746466473e12} + , {32, 18, 0.110649277244882e37} +}; + +const unsigned REGION3_PSATS_MAX = sizeof(REGION3_PSATS_DATA)/sizeof(BackwardsData); + +const double REGION3_PSATS_SSTAR = 5.2e3; +const double REGION3_PSATS_PSTAR = 22.e6; + +double freesteam_region3_psat_s(double s){ + BackwardsData *d, *e = REGION3_PSATS_DATA + REGION3_PSATS_MAX; + double sig = s / REGION3_PSATS_SSTAR; + double sig1 = sig - 1.03; + double sig2 = sig - 0.699; + double sum = 0; + for(d = REGION3_PSATS_DATA; d<e; ++d){ + sum += d->n * ipow(sig1, d->I) * ipow(sig2, d->J); + } + return sum * REGION3_PSATS_PSTAR; +} + + +/*------------------------------------------------------------------------------ + REGION 3 BACKWARDS EQUATION T(P,S) +*/ + +/** + Source: Revised_Release_Tv3ph_Tv3ps_Rev3.doc sect 3.4 +*/ +BackwardsData REGION3A_TPS_DATA[] = { + {-12, 28, 1500420082.63875} + ,{-12, 32, -159397258480.424} + ,{-10, 4, 5.02181140217975E-04} + ,{-10, 10, -67.2057767855466} + ,{-10, 12, 1450.58545404456} + ,{-10, 14, -8238.8953488889} + ,{-8, 5, -0.154852214233853} + ,{-8, 7, 11.2305046746695} + ,{-8, 8, -29.7000213482822} + ,{-8, 28, 43856513263.5495} + ,{-6, 2, 1.37837838635464E-03} + ,{-6, 6, -2.97478527157462} + ,{-6, 32, 9717779473494.13} + ,{-5, 0, -5.71527767052398E-05} + ,{-5, 14, 28830.794977842} + ,{-5, 32, -74442828926270.3} + ,{-4, 6, 12.8017324848921} + ,{-4, 10, -368.275545889071} + ,{-4, 36, 6.64768904779177E+15} + ,{-2, 1, 0.044935925195888} + ,{-2, 4, -4.22897836099655} + ,{-1, 1, -0.240614376434179} + ,{-1, 6, -4.74341365254924} + ,{0, 0, 0.72409399912611} + ,{0, 1, 0.923874349695897} + ,{0, 4, 3.99043655281015} + ,{1, 0, 3.84066651868009E-02} + ,{2, 0, -3.59344365571848E-03} + ,{2, 3, -0.735196448821653} + ,{3, 2, 0.188367048396131} + ,{8, 0, 1.41064266818704E-04} + ,{8, 1, -2.57418501496337E-03} + ,{10, 2, 1.23220024851555E-03} +}; + +const unsigned REGION3A_TPS_MAX = sizeof(REGION3A_TPS_DATA)/sizeof(BackwardsData); + +/** + Source: Revised_Release_Tv3ph_Tv3ps_Rev3.doc sect 3.4 +*/ +BackwardsData REGION3B_TPS_DATA[] = { + {-12, 1, 0.52711170160166} + ,{-12, 3, -40.1317830052742} + ,{-12, 4, 153.020073134484} + ,{-12, 7, -2247.99398218827} + ,{-8, 0, -0.193993484669048} + ,{-8, 1, -1.40467557893768} + ,{-8, 3, 42.6799878114024} + ,{-6, 0, 0.752810643416743} + ,{-6, 2, 22.6657238616417} + ,{-6, 4, -622.873556909932} + ,{-5, 0, -0.660823667935396} + ,{-5, 1, 0.841267087271658} + ,{-5, 2, -25.3717501764397} + ,{-5, 4, 485.708963532948} + ,{-5, 6, 880.531517490555} + ,{-4, 12, 2650155.92794626} + ,{-3, 1, -0.359287150025783} + ,{-3, 6, -656.991567673753} + ,{-2, 2, 2.41768149185367} + ,{0, 0, 0.856873461222588} + ,{2, 1, 0.655143675313458} + ,{3, 1, -0.213535213206406} + ,{4, 0, 5.62974957606348E-03} + ,{5, 24, -316955725450471.} + ,{6, 0, -6.99997000152457E-04} + ,{8, 3, 1.19845803210767E-02} + ,{12, 1, 1.93848122022095E-05} + ,{14, 2, -2.15095749182309E-05} +}; + +const unsigned REGION3B_TPS_MAX = sizeof(REGION3B_TPS_DATA)/sizeof(BackwardsData); + +const double REGION3A_TPS_TSTAR = 760.; /* K */ +const double REGION3A_TPS_SSTAR = 4.4e3; /* J/kgK */ +const double REGION3A_TPS_PSTAR = 100e6; /* Pa */ + +const double REGION3B_TPS_TSTAR = 860.; /* K */ +const double REGION3B_TPS_SSTAR = 5.3e3; /* J/kgK */ +const double REGION3B_TPS_PSTAR = 100e6; /* Pa */ + +const double REGION3AB_SC = 4.41202148223476e3; /* J/kgK */ + +/** + Backward equation for temperature in terms of pressure and entropy + in IAPWS-IF97 Region 3 (composed of sub-regions 3a, 3b). + + Source: IAPWS 'Revised Supplementary Release on Backward Equations for the Functions + T(p,h), v(p,h) and T(p,s), v(p,s) for Region 3 of the IAPWS Industrial + Formulation 1997 for the Thermodynamic Properties of Water and Steam', 2004. + + @param p pressure in Pa + @param s specific entropy in J/kgK + @return temperature in K +*/ +double freesteam_region3_T_ps(double p, double s){ + double p1, s1; + double Tstar; + BackwardsData *d; + unsigned i, n; + double sum = 0; + if(s < REGION3AB_SC){ + /* sub-region 3a */ + p1 = p/REGION3A_TPS_PSTAR + 0.240; s1 = s/REGION3A_TPS_SSTAR - 0.703; + d = REGION3A_TPS_DATA; + n = REGION3A_TPS_MAX; + Tstar = REGION3A_TPS_TSTAR; + }else{ + /* sub-region 3b */ + p1 = p/REGION3B_TPS_PSTAR + 0.760; s1 = s/REGION3B_TPS_SSTAR - 0.818; + d = REGION3B_TPS_DATA; + n = REGION3B_TPS_MAX; + Tstar = REGION3B_TPS_TSTAR; + } + + for(i = 0; i<n; ++i, ++d){ + sum += d->n * ipow(p1, d->I) * ipow(s1, d->J); + } + + return sum * Tstar; +} + + +/** + Source: Revised_Release_Tv3ph_Tv3ps_Rev3.doc sect 3.4 +*/ +BackwardsData REGION3A_VPS_DATA[] = { + {-12, 10, 0.795544074093975e2} + , {-12, 12, -0.238261242984590e4} + , {-12, 14, 0.176813100617787e5} + , {-10, 4, -0.110524727080379e-2} + , {-10, 8, -0.153213833655326e2} + , {-10, 10, 0.297544599376982e3} + , {-10, 20, -0.350315206871242e8} + , {-8, 5, 0.277513761062119} + , {-8, 6, -0.523964271036888} + , {-8, 14, -0.148011182995403e6} + , {-8, 16, 0.160014899374266e7} + , {-6, 28, 0.170802322663427e13} + , {-5, 1, 0.246866996006494e-3} + , {-4, 5, 0.165326084797980e1} + , {-3, 2, -0.118008384666987} + , {-3, 4, 0.253798642355900e1} + , {-2, 3, 0.965127704669424} + , {-2, 8, -0.282172420532826e2} + , {-1, 1, 0.203224612353823} + , {-1, 2, 0.110648186063513e1} + , {0, 0, 0.526127948451280} + , {0, 1, 0.277000018736321} + , {0, 3, 0.108153340501132e1} + , {1, 0, -0.744127885357893e-1} + , {2, 0, 0.164094443541384e-1} + , {4, 2, -0.680468275301065e-1} + , {5, 2, 0.257988576101640e-1} + , {6, 0, -0.145749861944416e-3} +}; + +const unsigned REGION3A_VPS_MAX = sizeof(REGION3A_VPS_DATA)/sizeof(BackwardsData); + +/** + Source: Revised_Release_Tv3ph_Tv3ps_Rev3.doc sect 3.4 +*/ +BackwardsData REGION3B_VPS_DATA[] = { + {-12, 0, 0.591599780322238e-4} + , {-12, 1, -0.185465997137856e-2} + , {-12, 2, 0.104190510480013e-1} + , {-12, 3, 0.598647302038590e-2} + , {-12, 5, -0.771391189901699} + , {-12, 6, 0.172549765557036e1} + , {-10, 0, -0.467076079846526e-3} + , {-10, 1, 0.134533823384439e-1} + , {-10, 2, -0.808094336805495e-1} + , {-10, 4, 0.508139374365767} + , {-8, 0, 0.128584643361683e-2} + , {-5, 1, -0.163899353915435e1} + , {-5, 2, 0.586938199318063e1} + , {-5, 3, -0.292466667918613e1} + , {-4, 0, -0.614076301499537e-2} + , {-4, 1, 0.576199014049172e1} + , {-4, 2, -0.121613320606788e2} + , {-4, 3, 0.167637540957944e1} + , {-3, 1, -0.744135838773463e1} + , {-2, 0, 0.378168091437659e-1} + , {-2, 1, 0.401432203027688e1} + , {-2, 2, 0.160279837479185e2} + , {-2, 3, 0.317848779347728e1} + , {-2, 4, -0.358362310304853e1} + , {-2, 12, -0.115995260446827e7} + , {0, 0, 0.199256573577909} + , {0, 1, -0.122270624794624} + , {0, 2, -0.191449143716586e2} + , {1, 0, -0.150448002905284e-1} + , {1, 2, 0.146407900162154e2} + , {2, 2, -0.327477787188230e1} +}; + +const unsigned REGION3B_VPS_MAX = sizeof(REGION3B_VPS_DATA)/sizeof(BackwardsData); + +const double REGION3A_VPS_VSTAR = 0.0028; /* kg/m3 */ +const double REGION3A_VPS_SSTAR = 4.4e3; /* J/kgK */ +const double REGION3A_VPS_PSTAR = 100e6; /* Pa */ + +const double REGION3B_VPS_VSTAR = 0.0088; /* kg/m3 */ +const double REGION3B_VPS_SSTAR = 5.3e3; /* J/kgK */ +const double REGION3B_VPS_PSTAR = 100e6; /* Pa */ + +/** + Backward equation for temperature in terms of pressure and entropy + in IAPWS-IF97 Region 3 (composed of sub-regions 3a, 3b). + + Source: IAPWS 'Revised Supplementary Release on Backward Equations for the Functions + T(p,h), v(p,h) and T(p,s), v(p,s) for Region 3 of the IAPWS Industrial + Formulation 1997 for the Thermodynamic Properties of Water and Steam', 2004. + + @param p pressure in Pa + @param s specific entropy in J/kgK + @return temperature in K +*/ +double freesteam_region3_v_ps(double p, double s){ + double p1, s1; + double vstar; + BackwardsData *d; + unsigned i, n; + double sum = 0; + if(s < REGION3AB_SC){ + /* sub-region 3a */ + p1 = p/REGION3A_VPS_PSTAR + 0.187; s1 = s/REGION3A_VPS_SSTAR - 0.755; + d = REGION3A_VPS_DATA; + n = REGION3A_VPS_MAX; + vstar = REGION3A_VPS_VSTAR; + }else{ + /* sub-region 3b */ + p1 = p/REGION3B_VPS_PSTAR + 0.298; s1 = s/REGION3B_VPS_SSTAR - 0.816; + d = REGION3B_VPS_DATA; + n = REGION3B_VPS_MAX; + vstar = REGION3B_VPS_VSTAR; + } + + for(i = 0; i<n; ++i, ++d){ + sum += d->n * ipow(p1, d->I) * ipow(s1, d->J); + } + + return sum * vstar; +} diff --git a/Utilib/src/backwards.h b/Utilib/src/backwards.h new file mode 100644 index 0000000..d0341cb --- /dev/null +++ b/Utilib/src/backwards.h @@ -0,0 +1,34 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#ifndef FREESTEAM_BACKWARDS_H +#define FREESTEAM_BACKWARDS_H + +#include "common.h" + +FREESTEAM_DLL double freesteam_region1_T_ph(double p, double h); +FREESTEAM_DLL double freesteam_region2_T_ph(double p, double h); +FREESTEAM_DLL double freesteam_region3_T_ph(double p, double h); +FREESTEAM_DLL double freesteam_region3_v_ph(double p, double h); +FREESTEAM_DLL double freesteam_region3_psat_h(double h); +FREESTEAM_DLL double freesteam_region3_psat_s(double s); + +FREESTEAM_DLL double freesteam_region3_T_ps(double p, double h); +FREESTEAM_DLL double freesteam_region3_v_ps(double p, double h); + +#endif diff --git a/Utilib/src/backwards_impl.h b/Utilib/src/backwards_impl.h new file mode 100644 index 0000000..6856b50 --- /dev/null +++ b/Utilib/src/backwards_impl.h @@ -0,0 +1,61 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*//** @file + Implementation details for backwards equations. Intended that + this header file would only be used for internal tests etc. +*/ +#ifndef FREESTEAM_BACKWARDS_IMPL_H +#define FREESTEAM_BACKWARDS_IMPL_H + +#include "common.h" + +#define SQ(X) ((X)*(X)) +#define CUBE(X) ((X)*(X)*(X)) + +/* boundary between subregions 3a and 3b in region 3 for (p,h) */ + +#define REGION3_B3AB_PSTAR (1.e6) +#define REGION3_B3AB_HSTAR (1.e3) +#define REGION3_B3AB_ETA(H) ((H)/REGION3_B3AB_HSTAR) +#define REGION3_B3AB_PI(P) ((P)/REGION3_B3AB_PSTAR) + +#define REGION3_B3AB_PH(P,H) (REGION3_B3AB_ETA(H) - (\ + 2014.64004206875 \ + + 3.74696550136983*REGION3_B3AB_PI(P) \ + - 2.19921901054187E-02 * SQ(REGION3_B3AB_PI(P)) \ + + 8.7513168600995E-05 * CUBE(REGION3_B3AB_PI(P)) \ + )) + + +/* boundary between subregions 2 and 3 in region 2 for (p,h) */ + +#define REGION2_B2BC_PSTAR (1.e6) +#define REGION2_B2BC_HSTAR (1.e3) +#define REGION2_B2BC_ETA(H) ((H)/REGION2_B2BC_HSTAR) +#define REGION2_B2BC_PI(P) ((P)/REGION2_B2BC_PSTAR) + +#define REGION2_B2BC_PH(P,H) (\ + (REGION2_B2BC_PI(P) - (\ + 905.84278514723 \ + - 0.67955786399241*REGION2_B2BC_ETA(H) \ + + 1.2809002730136E-04 * SQ(REGION2_B2BC_ETA(H)) \ + ))) + +#endif + + diff --git a/Utilib/src/bounds.c b/Utilib/src/bounds.c new file mode 100644 index 0000000..a8c8ec3 --- /dev/null +++ b/Utilib/src/bounds.c @@ -0,0 +1,69 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*//** @file + Functions to return SteamState objects for points on the + boundary of the ... +*/ + +#define FREESTEAM_BUILDING_LIB +#include "bounds.h" + +#include "region.h" +#include "b23.h" +#include "zeroin.h" + +#include <stdlib.h> + +typedef struct{ + double p, T; +} SteamPTData; + +static double pT3_fn(double rho, void *user_data){ +#define D ((SteamPTData *)user_data) + return D->p - freesteam_region3_p_rhoT(rho, D->T); +#undef D +} + +SteamState freesteam_bound_pmax_T(double T){ + SteamState S; + if(T <= REGION1_TMAX){ + S.region = 1; + S.valueR.R1.p = IAPWS97_PMAX; + S.valueR.R1.T = T; + }else if(T > freesteam_region2_s_pT(IAPWS97_PMAX,freesteam_b23_T_p(IAPWS97_PMAX))){ + S.region = 2; + S.valueR.R2.p = IAPWS97_PMAX; + S.valueR.R2.T = T; + }else{ + double tol = 1e-7; + double sol, err = 0; + double lb, ub; + SteamPTData D = {IAPWS97_PMAX, T}; + S.region = 3; + S.valueR.R3.T = T; + lb = 1./freesteam_region2_v_pT(freesteam_b23_p_T(T),T); + ub = 1./freesteam_region1_v_pT(IAPWS97_PMAX,REGION1_TMAX); + + if(zeroin_solve(&pT3_fn, &D, lb, ub, tol, &sol, &err)){ + fprintf(stderr,"%s (%s:%d): failed to solve for rho\n",__func__,__FILE__,__LINE__); + exit(1); + } + S.valueR.R3.rho = sol; + } + return S; +} diff --git a/Utilib/src/bounds.h b/Utilib/src/bounds.h new file mode 100644 index 0000000..9ac5e80 --- /dev/null +++ b/Utilib/src/bounds.h @@ -0,0 +1,31 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*//** @file + Functions to return SteamState objects for points on the + boundary of the ... +*/ +#ifndef FREESTEAM_BOUNDS_H +#define FREESTEAM_BOUNDS_H + +#include "common.h" +#include "steam.h" + +FREESTEAM_DLL SteamState freesteam_bound_pmax_T(double T); + +#endif + diff --git a/Utilib/src/common.c b/Utilib/src/common.c new file mode 100644 index 0000000..80ae291 --- /dev/null +++ b/Utilib/src/common.c @@ -0,0 +1,25 @@ +#define FREESTEAM_BUILDING_LIB +#include "common.h" + +/* ipow: public domain by Mark Stephen with suggestions by Keiichi Nakasato */ +double ipow(double x, int n){ + double t = 1.0; + + if(!n)return 1.0; /* At the top. x^0 = 1 */ + + if (n < 0){ + n = -n; + x = 1.0/x; /* error if x == 0. Good */ + } /* ZTC/SC returns inf, which is even better */ + + if (x == 0.0)return 0.0; + + do{ + if(n & 1)t *= x; + n /= 2; /* KN prefers if (n/=2) x*=x; This avoids an */ + x *= x; /* unnecessary but benign multiplication on */ + }while(n); /* the last pass, but the comparison is always + true _except_ on the last pass. */ + + return t; +} diff --git a/Utilib/src/common.h b/Utilib/src/common.h new file mode 100644 index 0000000..89afe12 --- /dev/null +++ b/Utilib/src/common.h @@ -0,0 +1,90 @@ +#ifndef FREESTEAM_COMMON_H +#define FREESTEAM_COMMON_H + +#include "config.h" + +#define FREESTEAM_CHAR int + +/* + ASCEND code in base/generic only EXPORTS symbols, no imports. + The FREESTEAM_DLLSPEC macro will, depending on whether we are + FREESTEAM_BUILDING_LIBASCEND (building libascend.so aka ascend.dll) + or FREESTEAM_BUILDING_INTERFACE (building for example _ascpy.dll or + ascendtcl.dll), act respectively to declare symbols as being + *exported* or *imported*. + + New versions of GCC are able to make use of these declarations + as well. +*/ +#ifdef __WIN32__ +# define FREESTEAM_EXPORT __declspec(dllexport) +# define FREESTEAM_IMPORT __declspec(dllimport) +#else +# ifdef HAVE_GCCVISIBILITY +# define FREESTEAM_EXPORT __attribute__ ((visibility("default"))) +# define FREESTEAM_IMPORT +# else +# define FREESTEAM_EXPORT +# define FREESTEAM_IMPORT +# endif +#endif + +#ifdef FREESTEAM_BUILDING_LIB +# define FREESTEAM_DLL extern FREESTEAM_EXPORT +#else +# define FREESTEAM_DLL extern FREESTEAM_IMPORT +#endif + +#if !defined(FREESTEAM_DLL) || !defined(FREESTEAM_EXPORT) || !defined(FREESTEAM_IMPORT) +# error "NO FREESTEAM_DLL DEFINED" +#endif + +/* Constants used throughout IAPWS-IF97 */ + +#define IAPWS97_PMAX 100e6 /* Pa */ +#define IAPWS97_TMIN 273.15 /* K */ +#define IAPWS97_TMAX 1073.15 /* K */ + +#define IAPWS97_TCRIT 647.096 /* K */ +#define IAPWS97_PCRIT 22.064e6 /* Pa */ +#define IAPWS97_RHOCRIT 322. /* kg/m3 */ + +#define IAPWS97_PTRIPLE 611.657 /* Pa */ + +#define IAPWS97_R 461.526 /* J/kgK */ + +#ifndef __GNUC__ +# define __func__ "<function>" +#endif + +#ifdef IAPWS97_WARN_APPROX +# define IAPWS97_APPROXIMATE \ + static char _warn_approx=0; \ + if(!_warn_approx){ \ + _warn_approx = 1; \ + fprintf(stderr \ + ,"WARNING: %s (%s:%d): backwards or approximation function used!\n" \ + ,__func__,__FILE__,__LINE__ \ + ); \ + } +#else +# define IAPWS97_APPROXIMATE +#endif + +#define SQ(X) ((X)*(X)) + +/* Basic math routines, if necesary... */ + +FREESTEAM_DLL double freesteam_ipow(double x, int n); + +#ifdef FREESTEAM_BUILDING_LIB +/* our local ipow implementation */ +# define ipow freesteam_ipow +/* 'isnan' function for use with Windows */ +# ifdef WIN32 +# include <float.h> +# define isnan _isnan +# endif +#endif + +#endif /* FREESTEAM_COMMON_H */ diff --git a/Utilib/src/config.h b/Utilib/src/config.h new file mode 100644 index 0000000..5f5544c --- /dev/null +++ b/Utilib/src/config.h @@ -0,0 +1,6 @@ +#ifndef FREESTEAM_CONFIG_H +#define FREESTEAM_CONFIG_H + +#define FREESTEAM_VERSION "2.0" + +#endif diff --git a/Utilib/src/freesteam_api.c b/Utilib/src/freesteam_api.c new file mode 100644 index 0000000..68b14f1 --- /dev/null +++ b/Utilib/src/freesteam_api.c @@ -0,0 +1,37 @@ + +/**********************************/ +/* C API for freesteam support */ +/* author: A. Hebert (27/05/2012) */ +/**********************************/ + +/* + Copyright (C) 2012 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + */ + +#include "steam.h" +#include "steam_pT.h" +#include "steam_Tx.h" +#include "region.h" + +void free_pT(double *P, double *T, double *RHO, double *H, double *ZK, double *ZMU, double *CP){ + SteamState State = freesteam_set_pT((double)*P, (double)*T); + *RHO = freesteam_rho(State); /*density*/ + *H = freesteam_h(State); /*enthalpy*/ + *ZK = freesteam_k(State); /*thermal conductivity*/ + *ZMU = freesteam_mu(State); /*dynamic viscosity*/ + *CP = freesteam_cp(State); /*isobaric heat capacity*/ +} + +void free_Tx(double *T, double *X, double *RHO, double *H, double *ZK, double *ZMU, double *CP){ + SteamState State = freesteam_set_Tx((double)*T, (double)*X); + *RHO = freesteam_rho(State); /*density*/ + *H = freesteam_h(State); /*enthalpy*/ + *ZK = freesteam_k(State); /*thermal conductivity*/ + *ZMU = freesteam_mu(State); /*dynamic viscosity*/ + *CP = freesteam_cp(State); /*isobaric heat capacity*/ +} diff --git a/Utilib/src/region.h b/Utilib/src/region.h new file mode 100644 index 0000000..5d58583 --- /dev/null +++ b/Utilib/src/region.h @@ -0,0 +1,137 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#ifndef FREESTEAM_REGION_H +#define FREESTEAM_REGION_H + +#include "common.h" + +FREESTEAM_DLL double freesteam_region1_u_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_v_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_s_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_h_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_cp_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_cv_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_w_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_a_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_g_pT(double p, double T); + +FREESTEAM_DLL double freesteam_region2_v_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_u_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_s_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_h_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_cp_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_cv_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_w_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_a_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_g_pT(double p, double T); + +FREESTEAM_DLL double freesteam_region3_p_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_u_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_s_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_h_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_cp_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_cv_rhoT(double rho, double T); + +FREESTEAM_DLL double freesteam_region4_psat_T(double T); +FREESTEAM_DLL double freesteam_region4_Tsat_p(double p); + +FREESTEAM_DLL double freesteam_region4_rhof_T(double T); +FREESTEAM_DLL double freesteam_region4_rhog_T(double T); + +FREESTEAM_DLL double freesteam_region4_v_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_u_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_h_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_s_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_cp_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_cv_Tx(double T, double x); + +FREESTEAM_DLL double freesteam_region4_dpsatdT_T(double T); + +/* used in calculations of derivatives, see derivs.c */ +double freesteam_region1_alphav_pT(double p, double T); +double freesteam_region1_kappaT_pT(double p, double T); + +double freesteam_region2_alphav_pT(double p, double T); +double freesteam_region2_kappaT_pT(double p, double T); + +double freesteam_region3_alphap_rhoT(double rho, double T); +double freesteam_region3_betap_rhoT(double rho, double T); + +FREESTEAM_DLL double freesteam_region1_u_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_v_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_s_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_h_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_cp_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_cv_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_w_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_a_pT(double p, double T); +FREESTEAM_DLL double freesteam_region1_g_pT(double p, double T); + +/* used in calculations of derivatives, see derivs.c */ +double freesteam_region1_alphav_pT(double p, double T); +double freesteam_region1_kappaT_pT(double p, double T); + +FREESTEAM_DLL double freesteam_region2_v_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_u_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_s_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_h_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_cp_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_cv_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_w_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_a_pT(double p, double T); +FREESTEAM_DLL double freesteam_region2_g_pT(double p, double T); + +/* used in calculations of derivatives, see derivs.c */ +double freesteam_region2_alphav_pT(double p, double T); +double freesteam_region2_kappaT_pT(double p, double T); + + +FREESTEAM_DLL double freesteam_region3_p_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_u_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_s_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_h_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_cp_rhoT(double rho, double T); +FREESTEAM_DLL double freesteam_region3_cv_rhoT(double rho, double T); + +/* FIXME implement freesteam_region3_w_rhoT */ + +/* used in calculations of derivatives, see derivs.c */ +double freesteam_region3_alphap_rhoT(double rho, double T); +double freesteam_region3_betap_rhoT(double rho, double T); + +FREESTEAM_DLL double freesteam_region4_psat_T(double T); +FREESTEAM_DLL double freesteam_region4_Tsat_p(double p); + +FREESTEAM_DLL double freesteam_region4_rhof_T(double T); +FREESTEAM_DLL double freesteam_region4_rhog_T(double T); + +FREESTEAM_DLL double freesteam_region4_v_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_u_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_h_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_s_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_cp_Tx(double T, double x); +FREESTEAM_DLL double freesteam_region4_cv_Tx(double T, double x); + +FREESTEAM_DLL double freesteam_region4_dpsatdT_T(double T); + +#define REGION1_TMAX 623.15 /* K */ +#define REGION2_TMAX 1073.15 + +#endif diff --git a/Utilib/src/region1.c b/Utilib/src/region1.c new file mode 100644 index 0000000..3028f6c --- /dev/null +++ b/Utilib/src/region1.c @@ -0,0 +1,194 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#define FREESTEAM_BUILDING_LIB +#include "region.h" + +static double gam(double pi, double tau); +static double gampi(double pi, double tau); +static double gampipi(double pi, double tau); +static double gamtau(double pi, double tau); +static double gamtautau(double pi, double tau); +static double gampitau(double pi, double tau); + +#define REGION1_GPT_PSTAR 16.53e6 /* Pa */ +#define REGION1_GPT_TSTAR 1386. /* K */ + +#define DEFINE_PITAU(P,T) \ + double pi = p / REGION1_GPT_PSTAR; \ + double tau = REGION1_GPT_TSTAR / T + +#define R IAPWS97_R + +#include <math.h> + +/*---------------------------------------------------------------- */ +/* REGION 1 G(p,T) EQUATIONS */ + +typedef struct{ + int I, J; + double n; +} IJNData; + +const IJNData REGION1_GPT_DATA[] = { + {0, -2, 0.14632971213167E+00} + ,{0, -1, -0.84548187169114E+00} + ,{0, 0, -0.37563603672040E+01} + ,{0, 1, 0.33855169168385E+01} + ,{0, 2, -0.95791963387872E+00} + ,{0, 3, 0.15772038513228E+00} + ,{0, 4, -0.16616417199501E-01} + ,{0, 5, 0.81214629983568E-03} + ,{1, -9, 0.28319080123804E-03} + ,{1, -7, -0.60706301565874E-03} + ,{1, -1, -0.18990068218419E-01} + ,{1, 0, -0.32529748770505E-01} + ,{1, 1, -0.21841717175414E-01} + ,{1, 3, -0.52838357969930E-04} + ,{2, -3, -0.47184321073267E-03} + ,{2, 0, -0.30001780793026E-03} + ,{2, 1, 0.47661393906987E-04} + ,{2, 3, -0.44141845330846E-05} + ,{2, 17, -0.72694996297594E-15} + ,{3, -4, -0.31679644845054E-04} + ,{3, 0, -0.28270797985312E-05} + ,{3, 6, -0.85205128120103E-09} + ,{4, -5, -0.22425281908000E-05} + ,{4, -2, -0.65171222895601E-06} + ,{4, 10, -0.14341729937924E-12} + ,{5, -8, -0.40516996860117E-06} + ,{8, -11, -0.12734301741641E-08} + ,{8, -6, -0.17424871230634E-09} + ,{21, -29, -0.68762131295531E-18} + ,{23, -31, 0.14478307828521E-19} + ,{29, -38, 0.26335781662795E-22} + ,{30, -39, -0.11947622640071E-22} + ,{31, -40, 0.18228094581404E-23} + ,{32, -41, -0.93537087292458E-25} +}; + +const unsigned REGION1_GPT_MAX = sizeof(REGION1_GPT_DATA)/sizeof(IJNData); + +#define REGION1_GPT_LOOP \ + double sum = 0; \ + const IJNData *d, *e = REGION1_GPT_DATA + REGION1_GPT_MAX; \ + for(d = REGION1_GPT_DATA; d < e; ++d) + +double gam(double pi, double tau){ + REGION1_GPT_LOOP{ + sum += d->n * ipow(7.1 - pi,d->I) * ipow(tau - 1.222,d->J); + } + return sum; +} + +double gampi(double pi, double tau){ + REGION1_GPT_LOOP{ + sum += -d->n * d->I * ipow(7.1 - pi,d->I -1) * ipow(tau - 1.222,d->J); + } + return sum; +} + +double gampipi(double pi, double tau){ + REGION1_GPT_LOOP{ + sum += d->n * d->I * (d->I - 1) * ipow(7.1 - pi, d->I - 2) * ipow(tau - 1.222, d->J); + } + return sum; +} + +double gamtau(double pi, double tau){ + REGION1_GPT_LOOP{ + sum += d->n * ipow(7.1 - pi, d->I) * d->J * ipow(tau - 1.222, d->J - 1); + } + return sum; +} + +double gamtautau(double pi, double tau){ + REGION1_GPT_LOOP{ + sum += d->n * ipow(7.1 - pi, d->I) * d->J * (d->J - 1) * ipow(tau - 1.222, d->J - 2); + } + return sum; +} + +double gampitau(double pi, double tau){ + REGION1_GPT_LOOP{ + sum += -d->n * d->I * ipow(7.1 - pi, d->I - 1) * d->J * ipow(tau - 1.222, d->J - 1); + } + return sum; +} + +double freesteam_region1_u_pT(double p, double T){ + DEFINE_PITAU(P,T); + return (R * T) * (tau * gamtau(pi,tau) - pi * gampi(pi,tau)); +} + +double freesteam_region1_v_pT(double p, double T){ + DEFINE_PITAU(P,T); + return (R * T / p) * pi * gampi(pi,tau); +} + +double freesteam_region1_s_pT(double p, double T){ + DEFINE_PITAU(P,T); + return R * (tau * gamtau(pi,tau) - gam(pi,tau)); +} + +double freesteam_region1_h_pT(double p, double T){ + DEFINE_PITAU(P,T); + return R * T * (tau * gamtau(pi,tau)); +} + +double freesteam_region1_cp_pT(double p, double T){ + DEFINE_PITAU(P,T); + return R * (-SQ(tau) * gamtautau(pi,tau)); +} + +double freesteam_region1_cv_pT(double p, double T){ + DEFINE_PITAU(P,T); + return R * (-SQ(tau) * gamtautau(pi,tau) + SQ(gampi(pi,tau) - + tau * gampitau(pi,tau)) / gampipi(pi,tau) + ); +} + +double freesteam_region1_w_pT(double p, double T){ + DEFINE_PITAU(P,T); + double gp = gampi(pi,tau); + return sqrt(R * T * SQ(gp) / \ + (SQ(gp - tau*gampitau(pi,tau))/SQ(tau)/gamtautau(pi,tau) - gampipi(pi,tau)) + ); +} + +double freesteam_region1_g_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * T * gam(pi,tau); +} + +double freesteam_region1_a_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * T * (gam(pi,tau) - gampi(pi,tau) * pi); +} + + +double freesteam_region1_alphav_pT(double p, double T){ + DEFINE_PITAU(P,T); + return 1./T * (1. - tau*gampitau(pi,tau)/gampi(pi,tau)); +} + +double freesteam_region1_kappaT_pT(double p, double T){ + DEFINE_PITAU(P,T); + return -1./p * pi*gampipi(pi,tau)/gampi(pi,tau); +} diff --git a/Utilib/src/region2.c b/Utilib/src/region2.c new file mode 100644 index 0000000..8ae1c33 --- /dev/null +++ b/Utilib/src/region2.c @@ -0,0 +1,278 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#define FREESTEAM_BUILDING_LIB +#include "region.h" + +#define GAM0(PI,TAU) gam0(PI,TAU) +#define GAM0PI(PI,TAU) (1./PI) +#define GAM0PIPI(PI,TAU) (-1./SQ(PI)) +#define GAM0TAU(PI,TAU) gam0tau(TAU) +#define GAM0TAUTAU(PI,TAU) gam0tautau(TAU) +#define GAM0PITAU(PI,TAU) (0) + +#define gam(PI,TAU) (GAM0(PI,TAU) + gamr(PI,TAU)) +#define gampi(PI,TAU) (GAM0PI(PI,TAU) + gamrpi(PI,TAU)) +#define gampipi(PI,TAU) (GAM0PIPI(PI,TAU) + gamrpipi(PI,TAU)) +#define gamtau(PI,TAU) (GAM0TAU(PI,TAU) + gamrtau(PI,TAU)) +#define gamtautau(PI,TAU) (GAM0TAUTAU(PI,TAU) + gamrtautau(PI,TAU)) +#define gampitau(PI,TAU) (GAM0PITAU(PI,TAU) + gamrpitau(PI,TAU)) + +static double gamr(double pi, double tau); +static double gamrpi(double pi, double tau); +static double gamrpipi(double pi, double tau); +static double gamrtau(double pi, double tau); +static double gamrtautau(double pi, double tau); +static double gamrpitau(double pi, double tau); + +static double gam0(double pi, double tau); +static double gam0tau(double tau); +static double gam0tautau(double tau); + +#include <math.h> +#include "common.h" + +#define R IAPWS97_R + +#define REGION2_GPT_PSTAR 1.e6 /* Pa */ +#define REGION2_GPT_TSTAR 540. /* K */ + +#define DEFINE_PITAU(P,T) \ + double pi = p / REGION2_GPT_PSTAR; \ + double tau = REGION2_GPT_TSTAR / T + + +double freesteam_region2_v_pT(double p, double T){ + DEFINE_PITAU(p,T); + return (R * T / p) * pi * gampi(pi,tau); +} + +double freesteam_region2_u_pT(double p, double T){ + DEFINE_PITAU(p,T); + return (R * T) * (tau * gamtau(pi,tau) - pi * gampi(pi,tau)); +} + +double freesteam_region2_s_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * (tau * gamtau(pi,tau) - gam(pi,tau)); +} + +double freesteam_region2_h_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * T * (tau * gamtau(pi,tau)); +} + +double freesteam_region2_cp_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * (-SQ(tau) * gamtautau(pi,tau)); +} + +double freesteam_region2_cv_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * (-SQ(tau) * gamtautau(pi,tau) + SQ(gampi(pi,tau) - + tau * gampitau(pi,tau)) / gampipi(pi,tau) + ); +} + +double freesteam_region2_w_pT(double p, double T){ + double gp; + DEFINE_PITAU(p,T); + gp = gamrpi(pi,tau); + return sqrt(R * T * (1. + 2.*pi*gp+SQ(pi*gp))/ + ((1. - SQ(pi)*gamrpipi(pi,tau)) + SQ(1. + pi*gp - tau*pi*gamrpitau(pi,tau))/SQ(tau)/gamtautau(pi,tau)) + ); +} + +double freesteam_region2_g_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * T * gam(pi,tau); +} + +double freesteam_region2_a_pT(double p, double T){ + DEFINE_PITAU(p,T); + return R * T * (gam(pi,tau) - gampi(pi,tau) * pi); +} + +double freesteam_region2_alphav_pT(double p, double T){ + double pigamrpi, alphav; + DEFINE_PITAU(p,T); + pigamrpi = pi*gamrpi(pi,tau); + alphav = 1./T * (1. + pigamrpi - tau*pi*gamrpitau(pi,tau))/(1. + pigamrpi); + return alphav; +} + +double freesteam_region2_kappaT_pT(double p, double T){ + double kappaT; + DEFINE_PITAU(p,T); + kappaT = 1./p * (1.-SQ(pi)*gamrpipi(pi,tau)) / (1.+pi*gamrpi(pi,tau)); + return kappaT; +} + +/*------------------------------------------------------------------------------ + REGION 2 IDEAL PART - GAM0(PI,TAU) +*/ + +typedef struct{ + int J; + double n; +} JNData; + +const JNData REGION2_GPT_IDEAL_DATA[] = { + {0, -0.96927686500217E+01} + ,{1, 0.10086655968018E+02} + ,{-5, -0.56087911283020E-02} + ,{-4, 0.71452738081455E-01} + ,{-3, -0.40710498223928E+00} + ,{-2, 0.14240819171444E+01} + ,{-1, -0.43839511319450E+01} + ,{2, -0.28408632460772E+00} + ,{3, 0.21268463753307E-01} +}; + +const unsigned REGION2_GPT_IDEAL_MAX = sizeof(REGION2_GPT_IDEAL_DATA)/sizeof(JNData); + +#define REGION2_GPT_IDEAL_LOOP \ + double sum = 0; \ + const JNData *d, *e = REGION2_GPT_IDEAL_DATA + REGION2_GPT_IDEAL_MAX; \ + for(d = REGION2_GPT_IDEAL_DATA; d < e; ++d) + +double gam0(double pi, double tau){ + REGION2_GPT_IDEAL_LOOP{ + sum += d->n * ipow(tau, d->J); + } + return log(pi) + sum; +} + +double gam0tau(double tau){ + REGION2_GPT_IDEAL_LOOP{ + sum += d->n * d->J * ipow(tau, d->J - 1); + } + return sum; +} + +double gam0tautau(double tau){ + REGION2_GPT_IDEAL_LOOP{ + sum += d->n * d->J * (d->J - 1) * ipow(tau, d->J - 2); + } + return sum; +} + +/*------------------------------------------------------------------------------ + REGION 2 RESIDUAL PART - GAMR(PI,TAU) +*/ + +typedef struct{ + int I, J; + double n; +} IJNData; + +const IJNData REGION2_GPT_RESID_DATA[] = { + {1, 0, -0.17731742473213E-02} + ,{1, 1, -0.17834862292358E-01} + ,{1, 2, -0.45996013696365E-01} + ,{1, 3, -0.57581259083432E-01} + ,{1, 6, -0.50325278727930E-01} + ,{2, 1, -0.33032641670203E-04} + ,{2, 2, -0.18948987516315E-03} + ,{2, 4, -0.39392777243355E-02} + ,{2, 7, -0.43797295650573E-01} + ,{2, 36, -0.26674547914087E-04} + ,{3, 0, 0.20481737692309E-07} + ,{3, 1, 0.43870667284435E-06} + ,{3, 3, -0.32277677238570E-04} + ,{3, 6, -0.15033924542148E-02} + ,{3, 35, -0.40668253562649E-01} + ,{4, 1, -0.78847309559367E-09} + ,{4, 2, 0.12790717852285E-07} + ,{4, 3, 0.48225372718507E-06} + ,{5, 7, 0.22922076337661E-05} + ,{6, 3, -0.16714766451061E-10} + ,{6, 16, -0.21171472321355E-02} + ,{6, 35, -0.23895741934104E+02} + ,{7, 0, -0.59059564324270E-17} + ,{7, 11, -0.12621808899101E-05} + ,{7, 25, -0.38946842435739E-01} + ,{8, 8, 0.11256211360459E-10} + ,{8, 36, -0.82311340897998E+01} + ,{9, 13, 0.19809712802088E-07} + ,{10, 4, 0.10406965210174E-18} + ,{10, 10, -0.10234747095929E-12} + ,{10, 14, -0.10018179379511E-08} + ,{16, 29, -0.80882908646985E-10} + ,{16, 50, 0.10693031879409E+00} + ,{18, 57, -0.33662250574171E+00} + ,{20, 20, 0.89185845355421E-24} + ,{20, 35, 0.30629316876232E-12} + ,{20, 48, -0.42002467698208E-05} + ,{21, 21, -0.59056029685639E-25} + ,{22, 53, 0.37826947613457E-05} + ,{23, 39, -0.12768608934681E-14} + ,{24, 26, 0.73087610595061E-28} + ,{24, 40, 0.55414715350778E-16} + ,{24, 58, -0.94369707241210E-06} +}; + +const unsigned REGION2_GPT_RESID_MAX = sizeof(REGION2_GPT_RESID_DATA)/sizeof(IJNData); + +#define REGION2_GPT_RESID_LOOP \ + double sum = 0; \ + const IJNData *d, *e = REGION2_GPT_RESID_DATA + REGION2_GPT_RESID_MAX; \ + for(d = REGION2_GPT_RESID_DATA; d < e; ++d) + +double gamr(double pi, double tau){ + REGION2_GPT_RESID_LOOP{ + sum += d->n * ipow(pi,d->I) * ipow(tau - 0.5,d->J); + } + return sum; +} + +double gamrpi(double pi, double tau){ + REGION2_GPT_RESID_LOOP{ + sum += d->n * d->I * ipow(pi,d->I -1) * ipow(tau - 0.5,d->J); + } + return sum; +} + +double gamrpipi(double pi, double tau){ + REGION2_GPT_RESID_LOOP{ + sum += d->n * d->I * (d->I - 1) * ipow(pi, d->I - 2) * ipow(tau - 0.5, d->J); + } + return sum; +} + +double gamrtau(double pi, double tau){ + REGION2_GPT_RESID_LOOP{ + sum += d->n * ipow(pi, d->I) * d->J * ipow(tau - 0.5, d->J - 1); + } + return sum; +} + +double gamrtautau(double pi, double tau){ + REGION2_GPT_RESID_LOOP{ + sum += d->n * ipow(pi, d->I) * d->J * (d->J - 1) * ipow(tau - 0.5, d->J - 2); + } + return sum; +} + +double gamrpitau(double pi, double tau){ + REGION2_GPT_RESID_LOOP{ + sum += d->n * d->I * ipow(pi, d->I - 1) * d->J * ipow(tau - 0.5, d->J - 1); + } + return sum; +} diff --git a/Utilib/src/region3.c b/Utilib/src/region3.c new file mode 100644 index 0000000..189fb79 --- /dev/null +++ b/Utilib/src/region3.c @@ -0,0 +1,185 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#define FREESTEAM_BUILDING_LIB +#include "region.h" + +const double REGION3_ARHOT_TSTAR = 647.096 /* K */; +const double REGION3_ARHOT_RHOSTAR = 322. /* K */; + +#define DEFINE_DELTAU(RHO,T) \ + double del = rho / REGION3_ARHOT_RHOSTAR; \ + double tau = REGION3_ARHOT_TSTAR / T + +#define R 461.526 + +static double phi(double del, double tau); +static double phidel(double del, double tau); +static double phideldel(double del, double tau); +static double phitau(double del, double tau); +static double phitautau(double del, double tau); +static double phideltau(double del, double tau); + +#include <math.h> + +double freesteam_region3_p_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return rho * R * T * del * phidel(del,tau); +} + +double freesteam_region3_u_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return R * T * tau * phitau(del,tau); +} + +double freesteam_region3_s_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return R * (tau * phitau(del,tau) - phi(del,tau)); +} + +double freesteam_region3_h_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return R * T * (tau * phitau(del,tau) + del * phidel(del,tau)); +} + +double freesteam_region3_cp_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return R * ( + -SQ(tau) * phitautau(del,tau) + + ( + ipow (del * phidel(del,tau) - del * tau * phideltau(del,tau), 2) + / (2 * del * phidel(del,tau) + SQ(del) * phideldel(del,tau)) + ) + ); +} + +double freesteam_region3_cv_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return R * (-SQ(tau) * phitautau(del,tau)); +} + +double freesteam_region3_alphap_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return 1./T * (1. - tau*phideltau(del,tau)/phidel(del,tau)); +} + +double freesteam_region3_betap_rhoT(double rho, double T){ + DEFINE_DELTAU(rho,T); + return rho*(2. + del * phideldel(del,tau)/phidel(del,tau)); +} + +/*----------------------------------------------------------------------------*/ + +typedef struct{ + int I, J; + double n; +} IJNData; + +const double REGION3_N1 = 0.10658070028513E+01; + +const IJNData REGION3_ARHOT_DATA[] = { + {0, 0, -0.15732845290239E+02} + ,{0, 1, 0.20944396974307E+02} + ,{0, 2, -0.76867707878716E+01} + ,{0, 7, 0.26185947787954E+01} + ,{0, 10, -0.28080781148620E+01} + ,{0, 12, 0.12053369696517E+01} + ,{0, 23, -0.84566812812502E-02} + ,{1, 2, -0.12654315477714E+01} + ,{1, 6, -0.11524407806681E+01} + ,{1, 15, 0.88521043984318E+00} + ,{1, 17, -0.64207765181607E+00} + ,{2, 0, 0.38493460186671E+00} + ,{2, 2, -0.85214708824206E+00} + ,{2, 6, 0.48972281541877E+01} + ,{2, 7, -0.30502617256965E+01} + ,{2, 22, 0.39420536879154E-01} + ,{2, 26, 0.12558408424308E+00} + ,{3, 0, -0.27999329698710E+00} + ,{3, 2, 0.13899799569460E+01} + ,{3, 4, -0.20189915023570E+01} + ,{3, 16, -0.82147637173963E-02} + ,{3, 26, -0.47596035734923E+00} + ,{4, 0, 0.43984074473500E-01} + ,{4, 2, -0.44476435428739E+00} + ,{4, 4, 0.90572070719733E+00} + ,{4, 26, 0.70522450087967E+00} + ,{5, 1, 0.10770512626332E+00} + ,{5, 3, -0.32913623258954E+00} + ,{5, 26, -0.50871062041158E+00} + ,{6, 0, -0.22175400873096E-01} + ,{6, 2, 0.94260751665092E-01} + ,{6, 26, 0.16436278447961E+00} + ,{7, 2, -0.13503372241348E-01} + ,{8, 26, -0.14834345352472E-01} + ,{9, 2, 0.57922953628084E-03} + ,{9, 26, 0.32308904703711E-02} + ,{10, 0, 0.80964802996215E-04} + ,{10, 1, -0.16557679795037E-03} + ,{11, 26, -0.44923899061815E-04} +}; + +const unsigned REGION3_ARHOT_MAX = sizeof(REGION3_ARHOT_DATA)/sizeof(IJNData); + +#define REGION3_ARHOT_LOOP \ + double sum = 0; \ + const IJNData *d, *e = REGION3_ARHOT_DATA + REGION3_ARHOT_MAX; \ + for(d = REGION3_ARHOT_DATA; d < e; ++d) + +double phi(double del, double tau){ + REGION3_ARHOT_LOOP{ + sum += d->n * ipow(del, d->I) * ipow(tau, d->J); + } + return sum + REGION3_N1 * log(del); +} + +double phidel(double del, double tau){ + REGION3_ARHOT_LOOP{ + sum += +d->n * d->I * ipow(del, d->I - 1) * ipow(tau, d->J); + } + return sum + REGION3_N1 / del; +} + +double phideldel(double del, double tau){ + REGION3_ARHOT_LOOP{ + sum += d->n * d->I * (d->I - 1) * ipow(del, d->I - 2) * ipow(tau, d->J); + } + return sum - REGION3_N1 / SQ(del) ; +} + +double phitau(double del, double tau){ + REGION3_ARHOT_LOOP{ + sum += d->n * ipow(del, d->I) * d->J * ipow(tau, d->J - 1); + } + return sum; +} + +double phitautau(double del, double tau){ + REGION3_ARHOT_LOOP{ + sum += d->n * ipow(del, d->I) * d->J * (d->J - 1) * ipow(tau, d->J - 2); + } + return sum; +} + +double phideltau(double del, double tau){ + REGION3_ARHOT_LOOP{ + sum += d->n * d->I * ipow(del, d->I - 1) * d->J * ipow(tau, d->J - 1); + } + return sum; +} diff --git a/Utilib/src/region4.c b/Utilib/src/region4.c new file mode 100644 index 0000000..49a9109 --- /dev/null +++ b/Utilib/src/region4.c @@ -0,0 +1,256 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#define FREESTEAM_BUILDING_LIB +#include "region.h" + +#include <math.h> +#include <stdlib.h> + +const double REGION4_N[11] = { 0, 0.11670521452767E+04, -0.72421316703206E+06 + , -0.17073846940092E+02, 0.12020824702470E+05, -0.32325550322333E+07 + , 0.14915108613530E+02, -0.48232657361591E+04, 0.40511340542057E+06 + , -0.23855557567849E+00, 0.65017534844798E+03 +}; + +#define REGION4_PSTAR 1e6 /* Pa */ +#define REGION4_TSTAR 1 /* K */ + +/*------------------------------------------------------------------------------ + REGION 4 SATURATION CURVE psat(T) +*/ + +double freesteam_region4_psat_T(double T){ + + double ups = T/REGION4_TSTAR + REGION4_N[9] / (T/REGION4_TSTAR - REGION4_N[10]); + double A = SQ(ups) + REGION4_N[1] * ups + REGION4_N[2]; + double B = REGION4_N[3] * SQ(ups) + REGION4_N[4] * ups + REGION4_N[5]; + double C = REGION4_N[6] * SQ(ups) + REGION4_N[7] * ups + REGION4_N[8]; + + double expr = 2. * C / (- B + sqrt(SQ(B) - 4. * A * C)); + double psat = SQ(SQ(expr)) * REGION4_PSTAR; + + /* fprintf(stderr,"freesteam_region4_psat_T = %f MPa\n", psat/1e6);*/ + return psat; +} + +/*------------------------------------------------------------------------------ + REGION 4 SATURATION CURVE Tsat(p) (BACKWARDS EQUATION) +*/ + +double freesteam_region4_Tsat_p(double p){ + double beta = pow(p/REGION4_PSTAR, 0.25); + double E = SQ(beta) + REGION4_N[3] * beta + REGION4_N[6]; + double F = REGION4_N[1] * SQ(beta) + REGION4_N[4] * beta + REGION4_N[7]; + double G = REGION4_N[2] * SQ(beta) + REGION4_N[5] * beta + REGION4_N[8]; + double D = 2. * G / (-F - sqrt(SQ(F) - 4. * E * G)); + + double theta = 0.5 * (REGION4_N[10] + D - sqrt(SQ(REGION4_N[10] + D) - 4.0 * (REGION4_N[9] + REGION4_N[10] * D))); + + /* FIXME iterative improve this estimate? is it necessary? */ + + return theta /* * REGION4_TSTAR = 1 {K} */; +} + +/*------------------------------------------------------------------------------ + REGION 4 DENSITIES rhof(T), rhog(T) (SUPPLEMENTARY EQUATIONS) +*/ + + + +/** + Coefficients for getSatDensWater_T +*/ +const double REGION4_B[7] + = { 0, 1.99274064, 1.09965342, -0.510839303, -1.75493479, -45.5170352, -6.74694450E+05 }; + +/** + Coefficients for getSatDensSteam_T +*/ +const double REGION4_C[7] + = { 0, -2.03150240, -2.68302940, -5.38626492, -17.2991605, -44.7586581, -63.9201063 }; + + +double freesteam_region4_rhof_T(double T){ + double tau = 1 - T / IAPWS97_TCRIT; + + double tau_1_3 = pow(tau,1./3); + + double tau_2_3 = SQ(tau_1_3); + double tau_5_3 = tau * tau_2_3; + double tau_16_3 = SQ(tau_5_3) * tau_5_3 * tau_1_3; + double tau_43_3 = SQ(tau_16_3) * SQ(tau_5_3) * tau_1_3; + double tau_110_3 = SQ(tau_43_3) * tau_16_3 * tau_5_3 * tau; + + double delta = 1 + + REGION4_B[1]*tau_1_3 + + REGION4_B[2]*tau_2_3 + + REGION4_B[3]*tau_5_3 + + REGION4_B[4]*tau_16_3 + + REGION4_B[5]*tau_43_3 + + REGION4_B[6]*tau_110_3; + + return delta * IAPWS97_RHOCRIT; + + /* FIXME iteratively improve vf estimate */ +} + +double freesteam_region4_rhog_T(double T){ + double tau = 1. - T / IAPWS97_TCRIT; + + double tau_1_6 = pow(tau,1.0/6); + + double tau_2_6 = SQ(tau_1_6); + double tau_4_6 = SQ(tau_2_6); + double tau_8_6 = SQ(tau_4_6); + double tau_16_6 = SQ(tau_8_6); + double tau_18_6 = tau_16_6 * tau_2_6; + double tau_37_6 = SQ(tau_18_6) * tau_1_6; + double tau_71_6 = tau_37_6 * tau_18_6 * tau_16_6; + + double ln_delta = + REGION4_C[1]*tau_2_6 + + REGION4_C[2]*tau_4_6 + + REGION4_C[3]*tau_8_6 + + REGION4_C[4]*tau_18_6 + + REGION4_C[5]*tau_37_6 + + REGION4_C[6]*tau_71_6; + + return exp(ln_delta) * IAPWS97_RHOCRIT; + + /* FIXME iteratively improve vg estimate */ +} + + +/*------------------------------------------------------------------------------ + INTERPOLATIONS FOR PROPERTIES WITHIN REGION 4 +*/ + +double freesteam_region4_v_Tx(double T, double x){ + double vf, vg; + if(T < REGION1_TMAX){ + double psat = freesteam_region4_psat_T(T); + vf = freesteam_region1_v_pT(psat,T); + vg = freesteam_region2_v_pT(psat,T); + }else{ + vf = 1./ freesteam_region4_rhof_T(T); + vg = 1./ freesteam_region4_rhog_T(T); + } + return vf + x*(vg - vf); +} + +double freesteam_region4_u_Tx(double T, double x){ + double uf, ug; + if(T < REGION1_TMAX){ + double psat = freesteam_region4_psat_T(T); + uf = freesteam_region1_u_pT(psat,T); + ug = freesteam_region2_u_pT(psat,T); + }else{ + double rhof, rhog; + rhof = freesteam_region4_rhof_T(T); + rhog = freesteam_region4_rhog_T(T); + uf = freesteam_region3_u_rhoT(rhof,T); + ug = freesteam_region3_u_rhoT(rhog,T); + } + return uf + x*(ug - uf); +} + +double freesteam_region4_h_Tx(double T, double x){ + double hf, hg; + if(T < REGION1_TMAX){ + double psat = freesteam_region4_psat_T(T); + hf = freesteam_region1_h_pT(psat,T); + hg = freesteam_region2_h_pT(psat,T); + }else{ + double rhof, rhog; + rhof = freesteam_region4_rhof_T(T); + rhog = freesteam_region4_rhog_T(T); + hf = freesteam_region3_h_rhoT(rhof,T); + hg = freesteam_region3_h_rhoT(rhog,T); + } + return hf + x*(hg - hf); +} + +double freesteam_region4_s_Tx(double T, double x){ + double sf, sg; + if(T < REGION1_TMAX){ + double psat = freesteam_region4_psat_T(T); + sf = freesteam_region1_s_pT(psat,T); + sg = freesteam_region2_s_pT(psat,T); + }else{ + double rhof, rhog; + rhof = freesteam_region4_rhof_T(T); + rhog = freesteam_region4_rhog_T(T); + sf = freesteam_region3_s_rhoT(rhof,T); + sg = freesteam_region3_s_rhoT(rhog,T); + } + return sf + x*(sg - sf); +} + +double freesteam_region4_cp_Tx(double T, double x){ + double cpf, cpg; + if(T < REGION1_TMAX){ + double psat = freesteam_region4_psat_T(T); + cpf = freesteam_region1_cp_pT(psat,T); + cpg = freesteam_region2_cp_pT(psat,T); + }else{ + double rhof, rhog; + rhof = freesteam_region4_rhof_T(T); + rhog = freesteam_region4_rhog_T(T); + cpf = freesteam_region3_cp_rhoT(rhof,T); + cpg = freesteam_region3_cp_rhoT(rhog,T); + } + return cpf + x*(cpg - cpf); +} + +double freesteam_region4_cv_Tx(double T, double x){ + double cvf, cvg; + if(T < REGION1_TMAX){ + double psat = freesteam_region4_psat_T(T); + cvf = freesteam_region1_cv_pT(psat,T); + cvg = freesteam_region2_cv_pT(psat,T); + }else{ + double rhof, rhog; + rhof = freesteam_region4_rhof_T(T); + rhog = freesteam_region4_rhog_T(T); + cvf = freesteam_region3_cv_rhoT(rhof,T); + cvg = freesteam_region3_cv_rhoT(rhog,T); + } + return cvf + x*(cvg - cvf); +} + +/*------------------------------------------------------------------------------ +*/ + +double freesteam_region4_dpsatdT_T(double T){ + /* calculated this derivative using implicit differentiation of the + quadratic expression, then derivatives of beta and script-theta */ + double beta = pow(freesteam_region4_psat_T(T)/REGION4_PSTAR, 0.25); +#define N REGION4_N + double theta = T/REGION4_TSTAR + N[9] / (T/REGION4_TSTAR - N[10]); + double XBETA = (2.*beta + N[3])*SQ(theta) + (2.*beta*N[1] + N[4])*theta + 2.*N[2]*beta + N[5]; + double XTHETA = (2.*theta + N[1])*SQ(beta) + (2.*N[3]*theta + N[4])*beta + 2.*N[6]*theta + N[7]; + + double dthetadT = (1 - N[9] / (T/REGION4_TSTAR - N[10]))/REGION4_TSTAR; + double dbetadtheta = -XTHETA/XBETA; + double dpdbeta = 4*SQ(beta)*beta*REGION4_PSTAR; +#undef N + + return dpdbeta * dbetadtheta * dthetadT; +} diff --git a/Utilib/src/steam.c b/Utilib/src/steam.c new file mode 100644 index 0000000..34b3934 --- /dev/null +++ b/Utilib/src/steam.c @@ -0,0 +1,317 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#define FREESTEAM_BUILDING_LIB +#include "steam.h" + +#include <stdlib.h> +#include <stdio.h> + +#include "region.h" +#include "b23.h" +#include "backwards.h" +#include "viscosity.h" +#include "thcond.h" + +/* 'setter' functions for SteamState (forwards equations) */ + +SteamState freesteam_region1_set_pT(double p, double T){ + SteamState S; + S.region = 1; + S.valueR.R1.p = p; + S.valueR.R1.T = T; + /* FIXME add bounds check? */ + return S; +} + +SteamState freesteam_region2_set_pT(double p, double T){ + SteamState S; + S.region = 2; + S.valueR.R2.p = p; + S.valueR.R2.T = T; + /* FIXME add bounds check? */ + return S; +} + +SteamState freesteam_region3_set_rhoT(double rho, double T){ + SteamState S; + S.region = 3; + S.valueR.R3.rho = rho; + S.valueR.R3.T = T; + /* FIXME add bounds check? */ + return S; +} + +SteamState freesteam_region4_set_Tx(double T, double x){ + SteamState S; + S.region = 4; + S.valueR.R4.T = T; + S.valueR.R4.x = x; + /* FIXME add bounds check? */ + return S; +} + +int freesteam_fprint(FILE *f, SteamState S){ + int n = 0; + n += fprintf(f, "region %d: ", S.region); + switch(S.region){ + case 1: + n += fprintf(f, "p = %f MPa, T = %f K\n", S.valueR.R1.p/1e6, S.valueR.R1.T); + break; + case 2: + n += fprintf(f, "p = %f MPa, T = %f K\n", S.valueR.R2.p/1e6, S.valueR.R2.T); + break; + case 3: + n += fprintf(f, "rho = %f kg/m3, T = %f K\n", S.valueR.R3.rho, S.valueR.R1.T); + break; + case 4: + n += fprintf(f, "T = %f, x = %f\n", S.valueR.R4.T, S.valueR.R4.x); + break; + } + return n; +} + +/* 'getter' functions for SteamState */ + +int freesteam_region(SteamState S){ + return (int)S.region; +} + +double freesteam_T(SteamState S){ + switch(S.region){ + case 1: + return S.valueR.R1.T; + case 2: + return S.valueR.R2.T; + case 3: + return S.valueR.R3.T; + case 4: + return S.valueR.R4.T; + default: + fprintf(stderr,"ERROR: invalid region in freesteam_T\n"); + exit(1); + } +} + +double freesteam_p(SteamState S){ + switch(S.region){ + case 1: + return S.valueR.R1.p; + case 2: + return S.valueR.R2.p; + case 3: + return freesteam_region3_p_rhoT(S.valueR.R3.rho, S.valueR.R3.T); + case 4: + return freesteam_region4_psat_T(S.valueR.R4.T); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_p\n"); + exit(1); + } +} + + +double freesteam_v(SteamState S){ + switch(S.region){ + case 1: + return freesteam_region1_v_pT(S.valueR.R1.p,S.valueR.R1.T); + case 2: + return freesteam_region2_v_pT(S.valueR.R2.p,S.valueR.R2.T); + case 3: + return 1./S.valueR.R3.rho; + case 4: + return freesteam_region4_v_Tx(S.valueR.R4.T, S.valueR.R4.x); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_v\n"); + exit(1); + } +} + +double freesteam_rho(SteamState S){ + switch(S.region){ + case 1: + return 1./freesteam_region1_v_pT(S.valueR.R1.p,S.valueR.R1.T); + case 2: + return 1./freesteam_region2_v_pT(S.valueR.R2.p,S.valueR.R2.T); + case 3: + return S.valueR.R3.rho; + case 4: + return 1./freesteam_region4_v_Tx(S.valueR.R4.T, S.valueR.R4.x); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_rho\n"); + exit(1); + } +} + + +double freesteam_u(SteamState S){ + switch(S.region){ + case 1: + return freesteam_region1_u_pT(S.valueR.R1.p, S.valueR.R1.T); + case 2: + return freesteam_region2_u_pT(S.valueR.R2.p, S.valueR.R2.T); + case 3: + return freesteam_region3_u_rhoT(S.valueR.R3.rho,S.valueR.R3.T); + case 4: + return freesteam_region4_u_Tx(S.valueR.R4.T, S.valueR.R4.x); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_u\n"); + exit(1); + } +} + +double freesteam_h(SteamState S){ + switch(S.region){ + case 1: + return freesteam_region1_h_pT(S.valueR.R1.p, S.valueR.R1.T); + case 2: + return freesteam_region2_h_pT(S.valueR.R2.p, S.valueR.R2.T); + case 3: + return freesteam_region3_h_rhoT(S.valueR.R3.rho,S.valueR.R3.T); + case 4: + return freesteam_region4_h_Tx(S.valueR.R4.T, S.valueR.R4.x); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_h\n"); + exit(1); + } +} + + +double freesteam_s(SteamState S){ + switch(S.region){ + case 1: + return freesteam_region1_s_pT(S.valueR.R1.p, S.valueR.R1.T); + case 2: + return freesteam_region2_s_pT(S.valueR.R2.p, S.valueR.R2.T); + case 3: + return freesteam_region3_s_rhoT(S.valueR.R3.rho,S.valueR.R3.T); + case 4: + return freesteam_region4_s_Tx(S.valueR.R4.T, S.valueR.R4.x); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_s\n"); + exit(1); + } +} + +double freesteam_cp(SteamState S){ + switch(S.region){ + case 1: + return freesteam_region1_cp_pT(S.valueR.R1.p, S.valueR.R1.T); + case 2: + return freesteam_region2_cp_pT(S.valueR.R2.p, S.valueR.R2.T); + case 3: + return freesteam_region3_cp_rhoT(S.valueR.R3.rho,S.valueR.R3.T); + case 4: + return freesteam_region4_cp_Tx(S.valueR.R4.T, S.valueR.R4.x); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_cp\n"); + exit(1); + } +} + +double freesteam_cv(SteamState S){ + switch(S.region){ + case 1: + return freesteam_region1_cv_pT(S.valueR.R1.p, S.valueR.R1.T); + case 2: + return freesteam_region2_cv_pT(S.valueR.R2.p, S.valueR.R2.T); + case 3: + return freesteam_region3_cv_rhoT(S.valueR.R3.rho,S.valueR.R3.T); + case 4: + return freesteam_region4_cv_Tx(S.valueR.R4.T, S.valueR.R4.x); + default: + fprintf(stderr,"ERROR: invalid region in freesteam_cv\n"); + exit(1); + } +} + +double freesteam_w(SteamState S){ + switch(S.region){ + case 1: + return freesteam_region1_w_pT(S.valueR.R1.p, S.valueR.R1.T); + case 2: + return freesteam_region2_w_pT(S.valueR.R2.p, S.valueR.R2.T); +#if 0 + case 3: + return freesteam_region3_w_rhoT(S.valueR.R3.rho,S.valueR.R3.T); + case 4: + return freesteam_region4_w_Tx(S.valueR.R4.T, S.valueR.R4.x); +#endif + default: + fprintf(stderr,"ERROR: invalid region '%d' in freesteam_w\n",S.region); + exit(1); + } +} + +double freesteam_x(SteamState S){ + switch(S.region){ + case 1: + return 0.; + case 2: + return 1.; + case 3: + if(S.valueR.R3.rho > IAPWS97_RHOCRIT)return 0.; + return 1.; + case 4: + return S.valueR.R4.x; + default: + fprintf(stderr,"ERROR: invalid region '%d' in freesteam_x\n",S.region); + exit(1); + } +} + +double freesteam_mu(SteamState S){ + static char warned = 0; + switch(S.region){ + case 1: + return freesteam_mu_rhoT(1./freesteam_region1_v_pT(S.valueR.R1.p,S.valueR.R1.T), S.valueR.R1.T); + case 2: + return freesteam_mu_rhoT(1./freesteam_region2_v_pT(S.valueR.R2.p,S.valueR.R2.T), S.valueR.R2.T); + case 3: + return freesteam_mu_rhoT(S.valueR.R3.rho, S.valueR.R3.T); + case 4: + if(!warned){ + fprintf(stderr,"WARNING: viscosity evaluation in region 4 is poorly defined! (this warning is only shown once)\n"); + warned = 1; + } + return freesteam_mu_rhoT(1./freesteam_region4_v_Tx(S.valueR.R4.T, S.valueR.R4.x), S.valueR.R4.T); + default: + fprintf(stderr,"ERROR: invalid region '%d' in freesteam_mu\n",S.region); + exit(1); + } +} + +double freesteam_k(SteamState S){ + static char warned = 0; + switch(S.region){ + case 1: + return freesteam_k_rhoT(1./freesteam_region1_v_pT(S.valueR.R1.p,S.valueR.R1.T), S.valueR.R1.T); + case 2: + return freesteam_k_rhoT(1./freesteam_region2_v_pT(S.valueR.R2.p,S.valueR.R2.T), S.valueR.R2.T); + case 3: + return freesteam_k_rhoT(S.valueR.R3.rho, S.valueR.R3.T); + case 4: + if(!warned){ + fprintf(stderr,"WARNING: thermal conductivity evaluation in region 4 is poorly defined! (this warning is only shown once)\n"); + warned = 1; + } + return freesteam_k_rhoT(1./freesteam_region4_v_Tx(S.valueR.R4.T, S.valueR.R4.x), S.valueR.R4.T); + default: + fprintf(stderr,"ERROR: invalid region '%d' in freesteam_k\n",S.region); + exit(1); + } +} diff --git a/Utilib/src/steam.h b/Utilib/src/steam.h new file mode 100644 index 0000000..9db9d06 --- /dev/null +++ b/Utilib/src/steam.h @@ -0,0 +1,89 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2005 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#ifndef FREESTEAM_STEAM_H +#define FREESTEAM_STEAM_H + +#include "common.h" + +#include <stdio.h> + +typedef struct SteamState_R1_struct{ + double p, T; +} SteamState_R1; + +typedef struct SteamState_R2_struct{ + double p, T; +} SteamState_R2; + +typedef struct SteamState_R3_struct{ + double rho, T; +} SteamState_R3; + +typedef struct SteamState_R4_struct{ + double T, x; +} SteamState_R4; + +typedef struct SteamState_struct{ + char region; + union{ + SteamState_R1 R1; + SteamState_R2 R2; + SteamState_R3 R3; + SteamState_R4 R4; + } valueR; +} SteamState; + +FREESTEAM_DLL int freesteam_region(SteamState S); + +FREESTEAM_DLL SteamState freesteam_region1_set_pT(double p, double T); +FREESTEAM_DLL SteamState freesteam_region2_set_pT(double p, double T); +FREESTEAM_DLL SteamState freesteam_region3_set_rhoT(double rho, double T); +FREESTEAM_DLL SteamState freesteam_region4_set_Tx(double T, double x); + +FREESTEAM_DLL int freesteam_fprint(FILE *f, SteamState S); + +#if 0 +# define FREESTEAM_DEBUG(NAME,STATE)\ + fprintf(stderr,"%s (%s:%d): %s ",__func__,__FILE__,__LINE__,NAME);\ + freesteam_fprint(stderr,S); +#else +# define FREESTEAM_DEBUG(NAME,STATE) +#endif + +typedef double SteamPropertyFunction(SteamState S); + +FREESTEAM_DLL double freesteam_p(SteamState S); +FREESTEAM_DLL double freesteam_T(SteamState S); +FREESTEAM_DLL double freesteam_rho(SteamState S); +FREESTEAM_DLL double freesteam_v(SteamState S); +FREESTEAM_DLL double freesteam_u(SteamState S); +FREESTEAM_DLL double freesteam_h(SteamState S); +FREESTEAM_DLL double freesteam_s(SteamState S); +FREESTEAM_DLL double freesteam_cp(SteamState S); +FREESTEAM_DLL double freesteam_cv(SteamState S); +FREESTEAM_DLL double freesteam_w(SteamState S); + +FREESTEAM_DLL double freesteam_x(SteamState S); + +FREESTEAM_DLL double freesteam_mu(SteamState S); +FREESTEAM_DLL double freesteam_k(SteamState S); + +#endif + + diff --git a/Utilib/src/steam_Ts.c b/Utilib/src/steam_Ts.c new file mode 100644 index 0000000..d5e88d0 --- /dev/null +++ b/Utilib/src/steam_Ts.c @@ -0,0 +1,197 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#define FREESTEAM_BUILDING_LIB +#include "steam.h" + +#include "region.h" +#include "zeroin.h" +#include "b23.h" +#include "bounds.h" +#include "backwards.h" + +#include <stdlib.h> +#include <assert.h> +#include <math.h> + +int freesteam_bounds_Ts(double T, double s, int verbose){ + double smax; +#define BOUND_WARN(MSG) \ + if(verbose){\ + fprintf(stderr,"%s (%s:%d): WARNING " MSG " (T = %g, s = %g kJ/kgK)\n"\ + ,__func__,__FILE__,__LINE__,T,s/1e3);\ + } + + if(T < IAPWS97_TMIN){ + BOUND_WARN("T < TMIN"); + return 1; + } + if(T > IAPWS97_TMAX + 1e-5){ + BOUND_WARN("T > TMAX"); + return 2; + } + + smax = freesteam_region2_s_pT(0.,T); + if(s > smax){ + BOUND_WARN("s > smax"); + return 3; + } + + if(T <= REGION1_TMAX){ + double smin = freesteam_region1_s_pT(IAPWS97_PMAX,T); + if(s < smin){ + BOUND_WARN("s < smin (region 1)"); + return 4; + } + }else if(T > freesteam_b23_T_p(IAPWS97_PMAX)){ + double smin = freesteam_region2_s_pT(IAPWS97_PMAX,T); + if(s < smin){ + BOUND_WARN("s < smin (region 2)"); + return 4; + } + }else{ + /* region 3, need to iterate */ + double smin; + SteamState S = freesteam_bound_pmax_T(T); + smin = freesteam_s(S); + if(s < smin){ + BOUND_WARN("s < smin (region 3)"); + return 4; + } + } + return 0; +#undef BOUND_WARN +} + +int freesteam_region_Ts(double T, double s){ + double p23, s23, psat, Tsat; + + if(T <= REGION1_TMAX){ + double p = freesteam_region4_psat_T(T); + double sf = freesteam_region1_s_pT(p,T); + double sg = freesteam_region2_s_pT(p,T); + if(s <= sf){ + return 1; + } + if(s >= sg){ + return 2; + } + return 4; + } + + /* an optimisation, using known range of s values on b23 IAPWS97 sect 4, p 5 */ + p23 = freesteam_b23_p_T(T); + s23 = freesteam_region2_s_pT(p23,T); + if(s >= s23){ + return 2; + } + + /* that leaves region 4 (near the C.P.) or region 3 */ + + /* FIXME need this hack to make low-s part of region behave correctly */ + if(s < 3.7e3)return 3; + + /* FIXME iterate to improve location of saturation curve? */ + psat = freesteam_region3_psat_s(s); + Tsat = freesteam_region4_Tsat_p(psat); + if(T > Tsat)return 3; + + return 4; +} + +typedef struct{ + double T, s, psat; +} SolveTSData; + +#define D ((SolveTSData *)user_data) +static ZeroInSubjectFunction Ts_region1_fn, Ts_region2_fn, Ts_region4_fn1, Ts_region4_fn2; +double Ts_region1_fn(double p, void *user_data){ + return D->s - freesteam_region1_s_pT(p, D->T); +} +double Ts_region2_fn(double p, void *user_data){ + return D->s - freesteam_region2_s_pT(p, D->T); +} +double Ts_region3_fn(double rho, void *user_data){ + return D->s - freesteam_region3_s_rhoT(rho, D->T); +} + +double Ts_region4_fn1(double x, void *user_data){ + /* for region 4 where T < REGION1_TMAX */ + double sf = freesteam_region1_s_pT(D->psat,D->T); + double sg = freesteam_region2_s_pT(D->psat,D->T); + return D->s - (sf + x*(sg-sf)); +} + +double Ts_region4_fn2(double x, void *user_data){ + /* for region 4 where T > REGION1_TMAX */ + double rhof = freesteam_region4_rhof_T(D->T); + double rhog = freesteam_region4_rhog_T(D->T); + double sf = freesteam_region3_s_rhoT(rhof,D->T); + double sg = freesteam_region3_s_rhoT(rhog,D->T); + /* TODO: iteratively improve guess with forward fns*/ + return D->s - (sf + x*(sg-sf)); +} +#undef D + +SteamState freesteam_set_Ts(double T, double s){ + double lb, ub, tol, sol = 0, err; + int region; + SolveTSData D = {T, s, 0}; + + region = freesteam_region_Ts(T,s); + switch(region){ + case 1: + lb = IAPWS97_PTRIPLE; + ub = IAPWS97_PMAX; + tol = 1e-9; /* ??? */ + zeroin_solve(&Ts_region1_fn, &D, lb, ub, tol, &sol, &err); + assert(fabs(err/sol)<tol); + return freesteam_region1_set_pT(sol,T); + case 2: + lb = 0.; + ub = IAPWS97_PMAX; + if(T > REGION1_TMAX && T < freesteam_b23_T_p(IAPWS97_PMAX)){ + ub = freesteam_b23_p_T(T); + } + tol = 1e-9; /* ??? */ + zeroin_solve(&Ts_region2_fn, &D, lb, ub, tol, &sol, &err); + return freesteam_region2_set_pT(sol,T); + case 3: + lb = 0; + ub = 1000; + tol = 1e-9; /* ??? */ + zeroin_solve(&Ts_region3_fn, &D, lb, ub, tol, &sol, &err); + assert(fabs(err/sol)<tol); + return freesteam_region3_set_rhoT(sol,T); + case 4: + lb = 0.; + ub = 1.; + tol = 1e-12; /* ??? */ + D.psat = freesteam_region4_psat_T(T); + zeroin_solve( + (T < REGION1_TMAX ? &Ts_region4_fn1 : &Ts_region4_fn2) + , &D, lb, ub, tol, &sol, &err + ); + assert(fabs(err)<tol); + return freesteam_region4_set_Tx(T,sol); + default: + /* ??? */ + fprintf(stderr,"%s (%s:%d): Region '%d' not implemented\n",__func__,__FILE__,__LINE__,region); + exit(1); + } +} diff --git a/Utilib/src/steam_Ts.h b/Utilib/src/steam_Ts.h new file mode 100644 index 0000000..719c293 --- /dev/null +++ b/Utilib/src/steam_Ts.h @@ -0,0 +1,32 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#ifndef FREESTEAM_STEAMTS_H +#define FREESTEAM_STEAMTS_H + +#include "common.h" +#include "steam.h" + +FREESTEAM_DLL int freesteam_bounds_Ts(double T, double s, int verbose); + +FREESTEAM_DLL int freesteam_region_Ts(double T, double s); + +FREESTEAM_DLL SteamState freesteam_set_Ts(double T, double s); + +#endif + diff --git a/Utilib/src/steam_Tx.c b/Utilib/src/steam_Tx.c new file mode 100644 index 0000000..496e4be --- /dev/null +++ b/Utilib/src/steam_Tx.c @@ -0,0 +1,140 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#define FREESTEAM_BUILDING_LIB +#include "steam_Tx.h" +#include "region.h" +#include "b23.h" +#include "zeroin.h" + +/* .... */ + +#include <stdlib.h> +#include <assert.h> +#include <math.h> + + +int freesteam_bounds_Tx(double T, double x, int verbose){ + +#define BOUND_WARN(MSG) \ + if(verbose){\ + fprintf(stderr,"%s (%s:%d): WARNING " MSG " (T = %g K, x = %g)\n"\ + ,__func__,__FILE__,__LINE__,T,x);\ + } + + if(T <= IAPWS97_TMIN){ + BOUND_WARN("T <= TMIN"); + return 1; + } + if(T > IAPWS97_TCRIT){ + BOUND_WARN("T > TCRIT"); + return 2; + } + + if(x < 0){ + BOUND_WARN("x < 0"); + return 3; + }else if(x > 1){ + BOUND_WARN("x > 1"); + return 4; + } + return 0; +#undef BOUND_WARN +} + +int freesteam_region_Tx(double T, double x){ + if(T >= IAPWS97_TCRIT)return 3; + + if(x <= 0){ + if(T > REGION1_TMAX)return 3; + return 1; + } + + if(x >= 1){ + if(T > REGION1_TMAX)return 3; + return 2; + } + + return 4; +} + +typedef struct{ + double T, s; +} SolveTSData; + +static double Ts_region3_fn(double rho, void *user_data){ +#define D ((SolveTSData *)user_data) + return D->s - freesteam_region3_s_rhoT(rho, D->T); +#undef D +} + +/** + This function will always return saturated mixtures; no negative or >1 + values of x are being 'understood' here (although one can give them meaning + based on extrapolated values of u or h of v, for example...) +*/ +SteamState freesteam_set_Tx(double T, double x){ + SteamState S; + + if(T >= IAPWS97_TCRIT){ + /* region 3 supercritical. just return a state with the specified + temperature and the critical point entropy. arbitrary. */ + double ub, lb, tol, sol, err; + SolveTSData D = {T, freesteam_region3_s_rhoT(IAPWS97_RHOCRIT, IAPWS97_TCRIT)}; + ub = 1./freesteam_region1_v_pT(IAPWS97_PMAX,REGION1_TMAX); + lb = 1./freesteam_region2_v_pT(freesteam_b23_p_T(T),T); + tol = 1e-7; + err = 0; + if(zeroin_solve(&Ts_region3_fn, &D, lb, ub, tol, &sol, &err)){ + fprintf(stderr,"%s (%s:%d): failed to solve for rho\n",__func__,__FILE__,__LINE__); + exit(1); + } + S.region = 3; + S.valueR.R3.T = T; + S.valueR.R3.rho = sol; + }else if(x <= 0){ + if(T > REGION1_TMAX){ + S.region = 3; + S.valueR.R3.T = T; + S.valueR.R3.rho = freesteam_region4_rhof_T(T); + /* FIXME iteratively refine the value */ + }else{ + S.region = 1; + S.valueR.R1.p = freesteam_region4_psat_T(T); + S.valueR.R1.T = T; + } + }else if(x >= 1){ + if(T > REGION1_TMAX){ + S.region = 3; + S.valueR.R3.T = T; + S.valueR.R3.rho = freesteam_region4_rhog_T(T); + /* FIXME iteratively refine the value */ + }else{ + S.region = 2; + S.valueR.R1.p = freesteam_region4_psat_T(T); + S.valueR.R1.T = T; + } + }else{ + /* finally! */ + S.region = 4; + S.valueR.R4.T = T; + S.valueR.R4.x = x; + } + + return S; +} diff --git a/Utilib/src/steam_Tx.h b/Utilib/src/steam_Tx.h new file mode 100644 index 0000000..190a609 --- /dev/null +++ b/Utilib/src/steam_Tx.h @@ -0,0 +1,32 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#ifndef FREESTEAM_STEAMTX_H +#define FREESTEAM_STEAMTX_H + +#include "common.h" +#include "steam.h" + +FREESTEAM_DLL int freesteam_bounds_Tx(double T, double x, int verbose); + +FREESTEAM_DLL int freesteam_region_Tx(double T, double x); + +FREESTEAM_DLL SteamState freesteam_set_Tx(double T, double x); + +#endif + diff --git a/Utilib/src/steam_pT.c b/Utilib/src/steam_pT.c new file mode 100644 index 0000000..3aa16b2 --- /dev/null +++ b/Utilib/src/steam_pT.c @@ -0,0 +1,94 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ +#define FREESTEAM_BUILDING_LIB +#include "steam_pT.h" +#include "region.h" +#include "zeroin.h" +#include "b23.h" + +#include <stdlib.h> +#include <assert.h> +#include <math.h> + +typedef struct{ + double p, T; +} SteamPTData; + +static double pT_region3_fn(double rho, void *user_data){ +#define D ((SteamPTData *)user_data) + return D->p - freesteam_region3_p_rhoT(rho, D->T); +#undef D +} + +/** + This function will never return region 4, because it's not possible + to 'sit on the knife' of saturation. If you need to set saturated states, + you should use another function such as freesteam_region1_set_Tx. +*/ +SteamState freesteam_set_pT(double p, double T){ + double tol, sol, err; + SteamState S; + if(T < REGION1_TMAX){ + if(p > freesteam_region4_psat_T(T)){ + S.region = 1; + S.valueR.R1.T = T; + S.valueR.R1.p = p; + }else{ + S.region = 2; + S.valueR.R2.T = T; + S.valueR.R2.p = p; + } + }else{ + /* FIXME some optimisation possiblxe here with test for lower pressures */ + double T23 = freesteam_b23_T_p(p); + double p23min = freesteam_b23_p_T(REGION1_TMAX); + if(p < p23min || T > T23){ + S.region = 2; + S.valueR.R2.T = T; + S.valueR.R2.p = p; + }else{ + /* FIXME the limit values are all wrong here! */ + double ub, lb; + SteamPTData D = {p,T}; + ub = 1./freesteam_region1_v_pT(IAPWS97_PMAX,REGION1_TMAX); + lb = 1./freesteam_region2_v_pT(freesteam_b23_p_T(T),T); + /* if we're in the little wee area around the critical pt... */ + if(T < IAPWS97_TCRIT){ + double psat = freesteam_region4_psat_T(T); + if(p < psat){ + ub = freesteam_region4_rhog_T(T); + assert(lb<ub); + }else{ + lb = freesteam_region4_rhof_T(T); + assert(lb<ub); + } + } + tol = 1e-7; + err = 0; + if(zeroin_solve(&pT_region3_fn, &D, lb, ub, tol, &sol, &err)){ + fprintf(stderr,"%s (%s:%d): failed to solve for rho\n",__func__,__FILE__,__LINE__); + exit(1); + } + S.region = 3; + S.valueR.R3.T = T; + S.valueR.R3.rho = sol; + } + } + return S; +} diff --git a/Utilib/src/steam_pT.h b/Utilib/src/steam_pT.h new file mode 100644 index 0000000..605fa53 --- /dev/null +++ b/Utilib/src/steam_pT.h @@ -0,0 +1,29 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#ifndef FREESTEAM_STEAMPT_H +#define FREESTEAM_STEAMPT_H + +#include "common.h" +#include "steam.h" + +FREESTEAM_DLL SteamState freesteam_set_pT(double p, double T); + +#endif + diff --git a/Utilib/src/t_saltdata.f90 b/Utilib/src/t_saltdata.f90 new file mode 100644 index 0000000..47a3014 --- /dev/null +++ b/Utilib/src/t_saltdata.f90 @@ -0,0 +1,75 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! module t_saltdata definition for the Fortran-2003 wrapper used to +! calculate Molten Salt thermophysical properties using data from the +! MSTPDB-TP Database +! +!Copyright: +! Copyright (C) 2023 Cristian Garrido Tamm +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): Cristian Garrido Tamm +! +!----------------------------------------------------------------------- +! +module t_saltdata + implicit none + type :: tpdata ! Salt thermophysical data structure + character(len=32) :: formula ! Chemical formula of the salt (e.g 'LiF-BeF2') + real :: weight ! Molecular weight + character(len=32) :: composition ! Salt composition (e.g 'Pure Salt' or '0.66-0.34') + real :: Tm ! Melting Temperature (K) + real :: Tb ! Boiling Temperature (K) + real :: rhoA ! A coefficient in density (g/cm3): A - BT(K) + real :: rhoB ! A coefficient in density (g/cm3): A - BT(K) + real :: zmu1A ! A coeff in Viscosity (mN*s/m2): A*exp(B/(R*T(K))) + real :: zmu1B ! B coeff in Viscosity (mN*s/m2): A*exp(B/(R*T(K))) + real :: zmu2A ! A coeff in Viscosity (mN*s/m2): 10^(A + B/T + C/T**2) + real :: zmu2B ! B coeff in Viscosity (mN*s/m2): 10^(A + B/T + C/T**2) + real :: zmu2C ! C coeff in Viscosity (mN*s/m2): 10^(A + B/T + C/T**2) + real :: zkA ! A coefficient in Thermal Conductivity (W/m K): A - B*T(K) + real :: zkB ! B coefficient in Thermal Conductivity (W/m K): A - B*T(K) + real :: cpA ! A coefficient in Heat Capacity (J/K mol) : A + B*T(K) + C*T-2(K) + D*T2(K) + real :: cpB ! B coefficient in Heat Capacity (J/K mol) : A + B*T(K) + C*T-2(K) + D*T2(K) + real :: cpC ! C coefficient in Heat Capacity (J/K mol) : A + B*T(K) + C*T-2(K) + D*T2(K) + real :: cpD ! D coefficient in Heat Capacity (J/K mol) : A + B*T(K) + C*T-2(K) + D*T2(K) + end type tpdata + +contains + real function dens(self, t) result(res) + ! Computes density (g/cm3) as A - B*T(K) + type(tpdata), intent(in) :: self + real, intent(in) :: t ! Temperature (K) + real, parameter :: f = 1000.0 ! g/cm3 to kg/m3 + res = (self%rhoA - self%rhoB * t) * f + end function + real function visc(self, t) result(res) + ! Computes Viscosity (mN*s/m2) as A*exp(B/(R*T(K))) or 10^(A + B/T + C/T**2) + type(tpdata), intent(in) :: self + real, intent(in) :: t ! Temperature (K) + real, parameter :: R = 8.314 ! J/K mol + real, parameter :: f = 1000.0 ! mN*s/m2 to kg/m2/s + real :: zmu1, zmu2 + zmu1 = self%zmu1A*exp(self%zmu1B/(R*t)) + zmu2 = 10**(self%zmu2A + self%zmu2B/t + self%zmu2C/T**2) + res = max(zmu1, zmu2)/1000 + end function + real function cond(self, t) result(res) + ! Computes Thermal Conductivity (W/m K) as A - B*T(K) + type(tpdata), intent(in) :: self + real, intent(in) :: t ! Temperature (K) + res = self%zkA - self%zkB * t + end function + real function cap(self, t) result(res) + ! Computes Heat Capacity (J/K mol) as A + B*T(K) + C*T**-2(K) + D*T**2(K) + type(tpdata), intent(in) :: self + real, intent(in) :: t ! Temperature (K) + res = self%cpA + self%cpB * t + self%cpC * t**(-2) + self%cpD * t**2 + res = res / self%weight * 1000 ! J/K/kg + end function +end module t_saltdata diff --git a/Utilib/src/thcond.c b/Utilib/src/thcond.c new file mode 100644 index 0000000..337e8b3 --- /dev/null +++ b/Utilib/src/thcond.c @@ -0,0 +1,102 @@ +/* + freesteam - IAPWS-IF97 steam tables library + Copyright (C) 2004-2009 John Pye + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +/* Appendix B: Recommended Interpolating equation for Industrial Use */ +/* see http://www.iapws.org/relguide/thcond.pdf */ + +#define FREESTEAM_BUILDING_LIB +#include "thcond.h" + +#include <math.h> + +#define THCOND_TSTAR 647.26 +#define THCOND_RHOSTAR 317.7 +#define THCOND_KSTAR 1.0 + +#define THCOND_b0 -0.397070 +#define THCOND_b1 0.400302 +#define THCOND_b2 1.060000 +#define THCOND_B1 -0.171587 +#define THCOND_B2 2.392190 + +#define THCOND_C1 0.642857 +#define THCOND_C2 -4.11717 +#define THCOND_C3 -6.17937 +#define THCOND_C4 0.00308976 +#define THCOND_C5 0.0822994 +#define THCOND_C6 10.0932 + +#define THCOND_d1 0.0701309 +#define THCOND_d2 0.0118520 +#define THCOND_d3 0.00169937 +#define THCOND_d4 -1.0200 + +/* freesteam code */ +double freesteam_k_rhoT(double rho, double T){ + +#define THCOND_a_COUNT 4 + const double THCOND_a[THCOND_a_COUNT] = { + 0.0102811 + ,0.0299621 + ,0.0156146 + ,-0.00422464 + }; + + double DTbar, DTbarpow, Q, S, rhobar18, rhobarQ; + double Tbar = T / THCOND_TSTAR; + double rhobar = rho / THCOND_RHOSTAR; + + /* fast implementation... minimised calls to 'pow' routine... */ + + double Troot = sqrt(Tbar); + double Tpow = Troot; + double lam = 0; + + int k; + for(k = 0; k < THCOND_a_COUNT; ++k) { + lam += THCOND_a[k] * Tpow; + Tpow *= Tbar; + } + + lam += THCOND_b0 + THCOND_b1 * rhobar + THCOND_b2 * exp(THCOND_B1 * SQ(rhobar + THCOND_B2)); + + DTbar = fabs(Tbar - 1) + THCOND_C4; + DTbarpow = pow(DTbar, 3./5); + Q = 2. + THCOND_C5 / DTbarpow; + + if(Tbar >= 1){ + S = 1. / DTbar; + }else{ + S = THCOND_C6 / DTbarpow; + } + + rhobar18 = pow(rhobar, 1.8); + rhobarQ = pow(rhobar, Q); + + lam += + (THCOND_d1 / ipow(Tbar,10) + THCOND_d2) * rhobar18 * + exp(THCOND_C1 * (1 - rhobar * rhobar18)) + + THCOND_d3 * S * rhobarQ * + exp((Q/(1+Q))*(1 - rhobar*rhobarQ)) + + THCOND_d4 * + exp(THCOND_C2 * ipow(Troot,3) + THCOND_C3 / ipow(rhobar,5)); + + return THCOND_KSTAR * lam; +} + diff --git a/Utilib/src/thcond.h b/Utilib/src/thcond.h new file mode 100644 index 0000000..d65f2ec --- /dev/null +++ b/Utilib/src/thcond.h @@ -0,0 +1,38 @@ +/* + freesteam - IAPWS-IF97 steam tables library + Copyright (C) 2004-2009 John Pye + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +#ifndef FREESTEAM_THCOND_H +#define FREESTEAM_THCOND_H + +#include "common.h" + +/* Conductivity [W/m.K] */ +/** + Returns the thermal conductivity of water/steam. + @see http://www.iapws.org/relguide/thcond.pdf + + Range of validity is entire regions 1,2,3. The correlation is not + really applicable in region 4, but will give 'sane' results there. + + @return Thermal conductivity [W/m.K] +*/ +FREESTEAM_DLL double freesteam_k_rhoT(double rho, double T); + +#endif + diff --git a/Utilib/src/viscosity.c b/Utilib/src/viscosity.c new file mode 100644 index 0000000..1b3f578 --- /dev/null +++ b/Utilib/src/viscosity.c @@ -0,0 +1,76 @@ +/* + freesteam - IAPWS-IF97 steam tables library + Copyright (C) 2004-2009 John Pye + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +/* + Based on IAPWS Formulation 2008 for the Viscosity of Ordinary Water Substance + */ + +#define FREESTEAM_BUILDING_LIB +#include "viscosity.h" + +static double mu0(double tau); +static double mu1(double del, double tau); + +#define VISCOSITY_MUSTAR 1.0e-6 /* Pa-s */ + +#include <math.h> + +static double mu0(double tau){ + const double H[4] = {1.67752, 2.20462, 0.6366564, -0.241605}; + int i; + double sum = 0; + for (i = 0; i < 4; i++){ + sum += H[i] * ipow(tau, i) ; + } + return 100.0 / (sqrt(tau) * sum); +} + + + +static double mu1(double del, double tau){ + const double H[6][7] = { + { 5.20094E-1, 2.22531E-1, -2.81378E-1, 1.61913E-1, -3.25372E-2, 0.0, 0.0}, + { 8.50895E-2, 9.99115E-1, -9.06851E-1, 2.57399E-1, 0.0, 0.0, 0.0}, + {-1.08374, 1.88797, -7.72479E-1, 0.0, 0.0, 0.0, 0.0}, + {-2.89555E-1, 1.26613, -4.89837E-1, 0.0, 6.98452E-2, 0.0, -4.35673E-3}, + { 0.0, 0.0, -2.57040E-1, 0.0, 0.0, 8.72102E-3, 0.0}, + { 0.0, 1.20573E-1, 0.0, 0.0, 0.0, 0.0, -5.93264E-4} + }; + + int i, j; + double sum = 0; + double tau1 = 0; + for (i = 0; i < 6; i++){ + tau1 = ipow(tau - 1, i); + for (j = 0; j < 7; j++){ + if(0==H[i][j])continue; + sum += H[i][j] * tau1 * ipow(del - 1, j); + } + } + return exp(del * sum); +} + +double freesteam_mu_rhoT(double rho, double T){ + double del = rho / IAPWS97_RHOCRIT; + double tau = IAPWS97_TCRIT / T; + + const int mu2 = 1; + /* critical enhancement to viscosity not implemented for IF-97, set to 1 */ + return VISCOSITY_MUSTAR * mu0(tau) * mu1(del,tau) * mu2; +} diff --git a/Utilib/src/viscosity.h b/Utilib/src/viscosity.h new file mode 100644 index 0000000..41f07cf --- /dev/null +++ b/Utilib/src/viscosity.h @@ -0,0 +1,31 @@ +/* + freesteam - IAPWS-IF97 steam tables library + Copyright (C) 2004-2009 John Pye + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +/* + Based on IAPWS Formulation 2008 for the Viscosity of Ordinary Water Substance + */ + +#ifndef FREESTEAM_VISCOSITY_H +#define FREESTEAM_VISCOSITY_H + +#include "common.h" + +FREESTEAM_DLL double freesteam_mu_rhoT(double rho, double T); + +#endif diff --git a/Utilib/src/zeroin.c b/Utilib/src/zeroin.c new file mode 100644 index 0000000..dc250ff --- /dev/null +++ b/Utilib/src/zeroin.c @@ -0,0 +1,139 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#define FREESTEAM_BUILDING_LIB +#include "zeroin.h" + +#include <math.h> +#include <stdio.h> + +#ifndef DBL_EPSILON + #define DBL_EPSILON 2e-16 +#endif + +char zeroin_solve(ZeroInSubjectFunction *func, void *user_data, double lowerbound, double upperbound, double tol, double *solution, double *error){ + + double a, b, c; /* Abscissae, descr. see above. */ + double fa; + double fb; + double fc; + + a = lowerbound; + b = upperbound; + fa = (*func)(a,user_data); + fb = (*func)(b,user_data); + c = a; + fc = fa; + + if(fa == 0.){ + *error = 0.; /* used by getError */ + *solution = a; + return 0; + } + + /* Main iteration loop */ + + for (;;) { + double prev_step = b - a; /* Distance from the last but one to the last approximation */ + double tol_act; /* Actual tolerance */ + double p; /* Interpolation step is calculated in the form p/q; division */ + double q; /* operations is delayed until the last moment */ + double new_step; /* Step at this iteration */ + + if (fabs(fc) < fabs(fb)) { + a = b; + b = c; + c = a; /* Swap data for b to be the best approximation */ + fa = fb; + fb = fc; + fc = fa; + } + + /* DBL_EPSILON is defined in math.h */ + tol_act = 2.0* DBL_EPSILON * fabs(b) + tol / 2.0; + + new_step = (c - b) / 2.0; + + if (fabs(new_step) <= tol_act || fb == 0.) { + *error = fb; + *solution = b; + return 0; + } + /* Decide if the interpolation can be tried */ + + if (fabs(prev_step) >= tol_act /* If prev_step was large enough and was in true direction, */ + && fabs(fa) > fabs(fb)) /* Interpolatiom may be tried */ + { + register double t1, t2; + double cb; + + cb = c - b; + if (a == c) { + /* If we have only two distinct points + then only linear interpolation can be applied */ + t1 = fb / fa; + p = cb * t1; + q = 1.0 - t1; + } else { + /* Quadric inverse interpolation */ + + q = fa / fc; + t1 = fb / fc; + t2 = fb / fa; + p = t2 * (cb * q * (q - t1) - (b - a) * (t1 - 1.0)); + q = (q - 1.0) * (t1 - 1.0) * (t2 - 1.0); + } + if (p > 0.) { + /* p was calculated with the opposite sign; make p positive- */ + q = -q; /* and assign possible minus to q */ + } else { + p = -p; + } + + if (p < (0.75 * cb * q - fabs(tol_act * q) / 2.0) + && p < fabs(prev_step * q / 2.0) + ) { + /* If b+p/q falls in [b,c] and + isn't too large it is accepted */ + new_step = p / q; + } + /* If p/q is too large then the bissection procedure can + reduce [b,c] range to more extent */ + } + + if (fabs(new_step) < tol_act) { /* Adjust the step to be not less */ + if (new_step > 0.) /* than tolerance */ + new_step = tol_act; + else + new_step = -tol_act; + } + + a = b; + fa = fb; /* Save the previous approx. */ + b += new_step; + fb = (*func)(b,user_data); /* Do step to a new approxim. */ + + if ((fb > 0. && fc > 0.) + || (fb < 0. && fc < 0.)) { + c = a; + fc = fa; /* Adjust c for it to have a sign opposite to that of b */ + } + } + /* (((we never arrive here))) */ +} diff --git a/Utilib/src/zeroin.h b/Utilib/src/zeroin.h new file mode 100644 index 0000000..bcd43fe --- /dev/null +++ b/Utilib/src/zeroin.h @@ -0,0 +1,65 @@ +/* +freesteam - IAPWS-IF97 steam tables library +Copyright (C) 2004-2009 John Pye + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +*/ + +#ifndef FREESTEAM_ZEROIN_H +#define FREESTEAM_ZEROIN_H + +#include "common.h" + +/** + Any function that you want to solve using the 'zeroin_solve' function + needs to conform to this function prototype. Any parameters required + internally by the function can be passed in to the function as a pointer + to a struct, array, etc, via the void 'user_data' pointer. Your subject + function can then cast the pointer to its correct type, and access the + necesssary parameter data, for example: + + -- in your main code + typedef struct{double param1, param2} MyData; + MyData D = {100., 3.141}; + double myfunc(double x, void *user_data){ + MyData *D1 = (MyData *)user_data; + return x * D1->param1 + D1->param2; + } + zeroin_solve(&myfunc, &D, ...); +*/ +typedef double ZeroInSubjectFunction(double, void *user_data); + +/** + Attempt to solve the function y = f(x) = 0 by varying x between + a lower and upper bound, using the Brent algorithm. + + Originally based on brent solver from netlib, then converted to C++ for + used in earlier freesteam versions, and now converted back to pure C again. + @see brent.shar at http://www.netlib.org/c/ + + @param func the function being solved, must be a ZeroInSubjectFunction. + @param lowerbound the lower bound of the range in which a root is sought + @param upperbound the upper bound of the range in which a root is sought + @param tol maximum permissible magnitude of the function at the solved root location + @param user_data additional data that will be passed to the subject function func. + @param solution (returned) the value of 'x' at the solution + @param error (returned) the value of 'y' at the solution. + @return 0 on success +*/ + +FREESTEAM_DLL char zeroin_solve(ZeroInSubjectFunction *func, void *user_data, double lowerbound, double upperbound, double tol, double *solution, double *error); + +#endif + |