C ALGORITHM 586, COLLECTED ALGORITHMS FROM ACM. C ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.8, NO. 3, C SEP., 1982, P. 302. SUBROUTINE JCG(NN,IA,JA,A,RHS,U,IWKSP,NW,WKSP, JCG 0010 A IPARM,RPARM,IERR) C C ITPACK 2C MAIN SUBROUTINE JCG (JACOBI CONJUGATE GRADIENT) C EACH OF THE MAIN SUBROUTINES: C JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI C CAN BE USED INDEPENDENTLY OF THE OTHERS C C ... FUNCTION: C C THIS SUBROUTINE, JCG, DRIVES THE JACOBI CONJUGATE C GRADIENT ALGORITHM. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS C THE LATEST ESTIMATE TO THE SOLUTION. C IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N C NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, C IPARM(8) IS AMOUNT USED. C WKSP REAL VECTOR USED FOR WORKING SPACE. JACOBI CONJUGATE C GRADIENT NEEDS THIS TO BE IN LENGTH AT LEAST C 4*N + 2*ITMAX, IF ISYM = 0 (SYMMETRIC STORAGE) C 4*N + 4*ITMAX, IF ISYM = 1 (NONSYMMETRIC STORAGE) C HERE ITMAX = IPARM(1) AND ISYM = IPARM(5) C (ITMAX IS THE MAXIMUM ALLOWABLE NUMBER OF ITERATIONS) C IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY C SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. C RPARM REAL VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME C REAL PARAMETERS WHICH AFFECT THE METHOD. C IER OUTPUT INTEGER. ERROR FLAG. (= IERR) C C ... JCG SUBPROGRAM REFERENCES: C C FROM ITPACK BISRCH, CHGCON, DETERM, DFAULT, ECHALL, C ECHOUT, EIGVNS, EIGVSS, EQRT1S, ITERM, ITICK, C ITJCG, ITOCK, IVFILL, PARCON, PERMAT, C PERROR, PERVEC, PJAC, PMULT, PRBNDX, C PSTOP, QSORT, SAXPY, SBELM, SCAL, SCOPY, C SDOT, SUM3, UNSCAL, VEVMW, VFILL, VOUT, C WEVMW, ZBRENT C SYSTEM ABS, ALOG10, AMAX0, AMAX1, MOD, SQRT C C VERSION: ITPACK 2C (MARCH 1982) C C CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS C CENTER FOR NUMERICAL ANALYSIS C UNIVERSITY OF TEXAS C AUSTIN, TX 78712 C (512) 471-1242 C C FOR ADDITIONAL DETAILS ON THE C (A) SUBROUTINE SEE TOMS ARTICLE 1982 C (B) ALGORITHM SEE CNA REPORT 150 C C BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN C C REFERENCE THE BOOK: APPLIED ITERATIVE METHODS C L. HAGEMAN, D. YOUNG C ACADEMIC PRESS, 1981 C C ************************************************** C * IMPORTANT NOTE * C * * C * WHEN INSTALLING ITPACK ROUTINES ON A * C * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * C * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * C * * C * SRELPR MACHINE RELATIVE PRECISION * C * RPARM(1) STOPPING CRITERION * C * * C * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * C * CPTIME USED IN ITICK AND ITOCK * C * * C ************************************************** C C SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IWKSP(1), IPARM(12), A NN, NW, IERR REAL A(1), RHS(NN), U(NN), WKSP(NW), RPARM(12) C C SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB1, IB2, IB3, IB4, IB5, IDGTS, IER, IERPER, ITIM1, ITIM2, A ITMAX1, JTIM1, JTIM2, LOOP, N, NB, NDUMMY, N3 REAL DIGIT1, DIGIT2, TEMP, TIME1, TIME2, TOL C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C ... VARIABLES IN COMMON BLOCK - ITCOM1 C C IN - ITERATION NUMBER C IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED C ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C LEVEL - LEVEL OF OUTPUT CONTROL SWITCH C NOUT - OUTPUT UNIT NUMBER C C ... VARIABLES IN COMMON BLOCK - ITCOM2 C C ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH C BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA C CASEII - ADAPTIVE PROCEDURE CASE SWITCH C HALT - STOPPING TEST SWITCH C PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH C C ... VARIABLES IN COMMON BLOCK - ITCOM3 C C BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N C BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX C CME - ESTIMATE OF LARGEST EIGENVALUE C DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N C DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S C FF - ADAPTIVE PROCEDURE DAMPING FACTOR C GAMMA - ACCELERATION PARAMETER C OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR C QA - PSEUDO-RESIDUAL RATIO C QT - VIRTUAL SPECTRAL RADIUS C RHO - ACCELERATION PARAMETER C RRR - ADAPTIVE PARAMETER C SIGE - PARAMETER SIGMA-SUB-E C SME - ESTIMATE OF SMALLEST EIGENVALUE C SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR C SRELPR - MACHINE RELATIVE PRECISION C STPTST - STOPPING PARAMETER C UDNM - TWO NORM OF U C ZETA - STOPPING CRITERION C C C ... INITIALIZE COMMON BLOCKS C LEVEL = IPARM(2) NOUT = IPARM(4) IF (LEVEL .GE. 1) WRITE(NOUT,1) 1 FORMAT(1H0 ///1X,40HBEGINNING OF ITPACK SOLUTION MODULE JCG ) IER = 0 IF(IPARM(1) .LE. 0) RETURN N = NN IF(IPARM(11) .EQ. 0) JTIM1 = ITICK(NDUMMY) IF (LEVEL .GE. 3) GO TO 2 CALL ECHOUT(IPARM,RPARM,1) GO TO 3 2 CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,1) 3 TEMP = 5.0E2*SRELPR IF (ZETA .GE. TEMP) GO TO 5 IF (LEVEL .GE. 1) WRITE (NOUT,4) ZETA,SRELPR,TEMP 4 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 25H IN ITPACK ROUTINE JCG B / 1H , 14H RPARM(1) =,E10.3,7H (ZETA) C / 1H , 46H A VALUE THIS SMALL MAY HINDER CONVERGENCE D / 1H , 36H SINCE MACHINE PRECISION SRELPR = ,E10.3 E / 1H , 18H ZETA RESET TO ,E10.3) ZETA = TEMP 5 CONTINUE TIME1 = RPARM(9) TIME2 = RPARM(10) DIGIT1 = RPARM(11) DIGIT2 = RPARM(12) C C ... VERIFY N C IF(N .GT. 0 ) GO TO 15 IER = 11 IF (LEVEL .GE. 0) WRITE(NOUT,14) N 14 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JCG B / 1H , 33H INVALID MATRIX DIMENSION, N =,I8) GO TO 160 15 CONTINUE C C ... REMOVE ROWS AND COLUMNS IF REQUESTED C IF(IPARM(10) .EQ. 0) GO TO 25 TOL = RPARM(8) CALL IVFILL(N,IWKSP,0) CALL VFILL(N,WKSP,0.0E0) CALL SBELM(N,IA,JA,A,RHS,IWKSP,WKSP,TOL,ISYM,LEVEL,NOUT,IER) IF(IER .EQ. 0) GO TO 25 IF (LEVEL .GE. 0) WRITE(NOUT,23) IER,TOL 23 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE SBELM C / 1H , 45H WHICH REMOVES ROWS AND COLUMNS OF SYSTEM D / 1H , 35H WHEN DIAGONAL ENTRY TOO LARGE E / 1H , 10H IER = ,I5,5X,12H RPARM(8) = ,E10.3,6H (TOL) ) GO TO 160 C C ... INITIALIZE WKSP BASE ADDRESSES. C 25 IB1 = 1 IB2 = IB1 + N IB3 = IB2 + N IB4 = IB3 + N IB5 = IB4 + N IPARM(8) = 4*N + 2*ITMAX IF(ISYM .NE. 0) IPARM(8) = IPARM(8) + 2*ITMAX IF (NW .GE. IPARM(8)) GO TO 40 IER = 12 IF (LEVEL .GE. 0) WRITE(NOUT,30) NW,IPARM(8) 30 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JCG B / 1H , 28H NOT ENOUGH WORKSPACE AT ,I10 C / 1H , 18H SET IPARM(8) =,I10,5H (NW) ) GO TO 160 C C ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED C 40 NB = IPARM(9) IF(NB .LT. 0) GO TO 50 N3 = 3*N CALL IVFILL(N3,IWKSP,0) CALL PRBNDX(N,NB,IA,JA,IWKSP,IWKSP(IB2),LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 43 IF (LEVEL .GE. 0) WRITE(NOUT,42) IER,NB 42 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PRBNDX C / 1H , 41H WHICH COMPUTES THE RED-BLACK INDEXING D / 1H , 10H IER = ,I5,12H IPARM(9) = ,I5,5H (NB) ) GO TO 160 C C ... PERMUTE MATRIX AND RHS C 43 IF (LEVEL .GE. 2) WRITE(NOUT,44) NB 44 FORMAT (/10X,27HORDER OF BLACK SUBSYSTEM = ,I5,5H (NB) ) CALL PERMAT(N,IA,JA,A,IWKSP,IWKSP(IB3),ISYM,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 46 IF (LEVEL .GE. 0) WRITE (NOUT,45) IER 45 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 40H WHICH DOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) GO TO 160 46 CALL PERVEC(N,RHS,IWKSP) CALL PERVEC(N,U,IWKSP) C C ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE C ... DIAGONAL ELEMENTS. C 50 CONTINUE CALL VFILL(IPARM(8),WKSP,0.0E0) CALL SCAL(N,IA,JA,A,RHS,U,WKSP,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 64 IF (LEVEL .GE. 0) WRITE(NOUT,60) IER 60 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE SCAL C / 1H , 30H WHICH SCALES THE SYSTEM D / 1H , 10H IER = ,I5) GO TO 160 64 IF (LEVEL .LE. 2) GO TO 70 WRITE(NOUT,66) 66 FORMAT(///1X,35HIN THE FOLLOWING, RHO AND GAMMA ARE A ,24H ACCELERATION PARAMETERS ) IF (ADAPT) WRITE(NOUT,67) 67 FORMAT(1X,48HCME IS THE ESTIMATE OF THE LARGEST EIGENVALUE OF A ,18H THE JACOBI MATRIX ) 70 IF(IPARM(11).NE.0)GO TO 75 ITIM1 = ITICK(NDUMMY) C C ... COMPUTE INITIAL PSEUDO-RESIDUAL C 75 CONTINUE CALL SCOPY(N,RHS,1,WKSP(IB2),1) CALL PJAC(N,IA,JA,A,U,WKSP(IB2)) CALL VEVMW(N,WKSP(IB2),U) C C ... ITERATION SEQUENCE C ITMAX1 = ITMAX + 1 DO 95 LOOP=1,ITMAX1 IN = LOOP -1 IF (MOD(IN,2) .EQ. 1) GO TO 85 C C ... CODE FOR THE EVEN ITERATIONS. C C U = U(IN) WKSP(IB2) = DEL(IN) C WKSP(IB1) = U(IN-1) WKSP(IB3) = DEL(IN-1) C CALL ITJCG(N,IA,JA,A,U,WKSP(IB1),WKSP(IB2),WKSP(IB3), A WKSP(IB4),WKSP(IB5)) C IF (HALT) GO TO 132 GO TO 95 C C ... CODE FOR THE ODD ITERATIONS. C C U = U(IN-1) WKSP(IB2) = DEL(IN-1) C WKSP(IB1) = U(IN) WKSP(IB3) = DEL(IN) C 85 CALL ITJCG(N,IA,JA,A,WKSP(IB1),U,WKSP(IB3),WKSP(IB2), A WKSP(IB4),WKSP(IB5)) C IF (HALT) GO TO 132 95 CONTINUE C C ... ITMAX HAS BEEN REACHED C IF(IPARM(11).NE.0)GO TO 125 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 125 IER = 13 IF (LEVEL .GE. 1) WRITE(NOUT,130) ITMAX 130 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 25H IN ITPACK ROUTINE JCG B / 1H , 26H FAILURE TO CONVERGE IN ,I5, 11H ITERATIONS ) IF (IPARM(3) .EQ. 0) RPARM(1) = STPTST GO TO 140 C C ... METHOD HAS CONVERGED C 132 IF(IPARM(11).NE.0) GO TO 134 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 134 IF (LEVEL .GE. 1) WRITE(NOUT,136) IN 136 FORMAT(/1X,22HJCG HAS CONVERGED IN ,I5,11H ITERATIONS ) C C ... PUT SOLUTION INTO U IF NOT ALREADY THERE. C 140 CONTINUE IF (MOD(IN,2) .EQ. 1) CALL SCOPY(N,WKSP(IB1),1,U,1) C C ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. C CALL UNSCAL(N,IA,JA,A,RHS,U,WKSP) C C ... UN-PERMUTE MATRIX,RHS, AND SOLUTION C IF(IPARM(9) .LT. 0) GO TO 145 CALL PERMAT (N,IA,JA,A,IWKSP(IB2),IWKSP(IB3),ISYM, A LEVEL,NOUT,IERPER) IF (IERPER .EQ. 0) GO TO 144 IF (LEVEL .GE. 0) WRITE(NOUT,142) IERPER 142 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 45H WHICH UNDOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) IF(IER .EQ. 0) IER = IERPER GO TO 160 144 CALL PERVEC(N,RHS,IWKSP(IB2)) CALL PERVEC(N,U,IWKSP(IB2)) C C ... OPTIONAL ERROR ANALYSIS C 145 IDGTS = IPARM(12) IF(IDGTS .LT. 0) GO TO 150 IF(IPARM(2) .LE. 0) IDGTS = 0 CALL PERROR(N,IA,JA,A,RHS,U,WKSP,DIGIT1,DIGIT2,IDGTS) C C ... SET RETURN PARAMETERS IN IPARM AND RPARM C 150 IPARM(8) = IPARM(8) - 2 * (ITMAX - IN) IF(IPARM(11) .NE. 0) GO TO 155 JTIM2 = ITOCK(NDUMMY) TIME2 = AMAX0(0,JTIM2 - JTIM1)*1.E-3 155 IF(ISYM .NE. 0) IPARM(8) = IPARM(8) - 2*(ITMAX - IN) IF (IPARM(3) .NE. 0) GO TO 160 IPARM(1) = IN IPARM(9) = NB RPARM(2) = CME RPARM(3) = SME RPARM(9) = TIME1 RPARM(10) = TIME2 RPARM(11) = DIGIT1 RPARM(12) = DIGIT2 C 160 CONTINUE IERR = IER IF (LEVEL .GE. 3) CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,2) C RETURN END SUBROUTINE JSI(NN,IA,JA,A,RHS,U,IWKSP,NW,WKSP, JSI 0010 A IPARM,RPARM,IERR) C C ITPACK 2C MAIN SUBROUTINE JSI (JACOBI SEMI-ITERATIVE) C EACH OF THE MAIN SUBROUTINES: C JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI C CAN BE USED INDEPENDENTLY OF THE OTHERS C C ... FUNCTION: C C THIS SUBROUTINE, JSI, DRIVES THE JACOBI SEMI- C ITERATION ALGORITHM. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS C THE LATEST ESTIMATE TO THE SOLUTION. C IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N C NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, C IPARM(8) IS AMOUNT USED. C WKSP REAL VECTOR USED FOR WORKING SPACE. JACOBI SI C GRADIENT NEEDS THIS TO BE IN LENGTH AT LEAST C 2*N C IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY C SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. C RPARM REAL VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME C REAL PARAMETERS WHICH AFFECT THE METHOD. C IER OUTPUT INTEGER. ERROR FLAG. (= IERR) C C ... JSI SUBPROGRAM REFERENCES: C C FROM ITPACK BISRCH, CHEBY, CHGSI, CHGSME, DFAULT, ECHALL, C ECHOUT, ITERM, ITICK, ITJSI, ITOCK, IVFILL, PAR C PERMAT, PERROR, PERVEC, PJAC, PMULT, PRBNDX, C PSTOP, PVTBV, QSORT, SAXPY, SBELM, SCAL, C SCOPY, SDOT, SUM3, TSTCHG, UNSCAL, VEVMW, C VFILL, VOUT, WEVMW C SYSTEM ABS, ALOG10, AMAX0, AMAX1, FLOAT, MOD, SQRT C C VERSION: ITPACK 2C (MARCH 1982) C C CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS C CENTER FOR NUMERICAL ANALYSIS C UNIVERSITY OF TEXAS C AUSTIN, TX 78712 C (512) 471-1242 C C FOR ADDITIONAL DETAILS ON THE C (A) SUBROUTINE SEE TOMS ARTICLE 1982 C (B) ALGORITHM SEE CNA REPORT 150 C C BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN C C REFERENCE THE BOOK: APPLIED ITERATIVE METHODS C L. HAGEMAN, D. YOUNG C ACADEMIC PRESS, 1981 C C ************************************************** C * IMPORTANT NOTE * C * * C * WHEN INSTALLING ITPACK ROUTINES ON A * C * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * C * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * C * * C * SRELPR MACHINE RELATIVE PRECISION * C * RPARM(1) STOPPING CRITERION * C * * C * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * C * CPTIME USED IN ITICK AND ITOCK * C * * C ************************************************** C C C SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IWKSP(1), IPARM(12), A NN, NW, IERR REAL A(1), RHS(NN), U(NN), WKSP(NW), RPARM(12) C C SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB1, IB2, IB3, ICNT, IDGTS, IER, IERPER, ITIM1, ITIM2, A ITMAX1, JTIM1, JTIM2, LOOP, N, NB, NDUMMY, N3 REAL DIGIT1, DIGIT2, TEMP, TIME1, TIME2, TOL C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C ... VARIABLES IN COMMON BLOCK - ITCOM1 C C IN - ITERATION NUMBER C IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED C ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C LEVEL - LEVEL OF OUTPUT CONTROL SWITCH C NOUT - OUTPUT UNIT NUMBER C C ... VARIABLES IN COMMON BLOCK - ITCOM2 C C ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH C BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA C CASEII - ADAPTIVE PROCEDURE CASE SWITCH C HALT - STOPPING TEST SWITCH C PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH C C ... VARIABLES IN COMMON BLOCK - ITCOM3 C C BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N C BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX C CME - ESTIMATE OF LARGEST EIGENVALUE C DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N C DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S C FF - ADAPTIVE PROCEDURE DAMPING FACTOR C GAMMA - ACCELERATION PARAMETER C OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR C QA - PSEUDO-RESIDUAL RATIO C QT - VIRTUAL SPECTRAL RADIUS C RHO - ACCELERATION PARAMETER C RRR - ADAPTIVE PARAMETER C SIGE - PARAMETER SIGMA-SUB-E C SME - ESTIMATE OF SMALLEST EIGENVALUE C SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR C SRELPR - MACHINE RELATIVE PRECISION C STPTST - STOPPING PARAMETER C UDNM - TWO NORM OF U C ZETA - STOPPING CRITERION C C C ... INITIALIZE COMMON BLOCKS C LEVEL = IPARM(2) NOUT = IPARM(4) IF (LEVEL .GE. 1) WRITE(NOUT,1) 1 FORMAT(1H0 ///1X,40HBEGINNING OF ITPACK SOLUTION MODULE JSI ) IER = 0 IF(IPARM(1) .LE. 0) RETURN N = NN IF(IPARM(11) .EQ. 0) JTIM1 = ITICK(NDUMMY) IF (LEVEL .GE. 3) GO TO 2 CALL ECHOUT(IPARM,RPARM,2) GO TO 3 2 CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,1) 3 TEMP = 5.0E2*SRELPR IF (ZETA .GE. TEMP) GO TO 5 IF (LEVEL .GE. 1) WRITE (NOUT,4) ZETA,SRELPR,TEMP 4 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 25H IN ITPACK ROUTINE JSI B / 1H , 14H RPARM(1) =,E10.3,7H (ZETA) C / 1H , 46H A VALUE THIS SMALL MAY HINDER CONVERGENCE D / 1H , 36H SINCE MACHINE PRECISION SRELPR = ,E10.3 E / 1H , 18H ZETA RESET TO ,E10.3) ZETA = TEMP 5 CONTINUE TIME1 = RPARM(9) TIME2 = RPARM(10) DIGIT1 = RPARM(11) DIGIT2 = RPARM(12) C C ... VERIFY N C IF(N .GT. 0 ) GO TO 15 IER = 21 IF (LEVEL .GE. 0) WRITE(NOUT,14) N 14 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JSI B / 1H , 33H INVALID MATRIX DIMENSION, N =,I8) GO TO 160 15 CONTINUE C C ... REMOVE ROWS AND COLUMNS IF REQUESTED C IF(IPARM(10) .EQ. 0) GO TO 25 TOL = RPARM(8) CALL IVFILL(N,IWKSP,0) CALL VFILL(N,WKSP,0.0E0) CALL SBELM(N,IA,JA,A,RHS,IWKSP,WKSP,TOL,ISYM,LEVEL,NOUT,IER) IF(IER .EQ. 0) GO TO 25 IF (LEVEL .GE. 0) WRITE(NOUT,23) IER,TOL 23 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE SBELM C / 1H , 45H WHICH REMOVES ROWS AND COLUMNS OF SYSTEM D / 1H , 35H WHEN DIAGONAL ENTRY TOO LARGE E / 1H , 10H IER = ,I5,5X,12H RPARM(8) = ,E10.3,6H (TOL) ) GO TO 160 C C ... INITIALIZE WKSP BASE ADDRESSES. C 25 IB1 = 1 IB2 = IB1 + N IB3 = IB2 + N IPARM(8) = 2*N IF (NW .GE. IPARM(8)) GO TO 40 IER = 22 IF (LEVEL .GE. 0) WRITE(NOUT,27) NW,IPARM(8) 27 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JSI B / 1H , 28H NOT ENOUGH WORKSPACE AT ,I10 C / 1H , 18H SET IPARM(8) =,I10,5H (NW) ) GO TO 160 C C ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED C 40 NB = IPARM(9) IF(NB .LT. 0) GO TO 50 N3 = 3*N CALL IVFILL(N3,IWKSP,0) CALL PRBNDX(N,NB,IA,JA,IWKSP,IWKSP(IB2),LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 43 IF (LEVEL .GE. 0) WRITE(NOUT,42) IER,NB 42 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PRBNDX C / 1H , 41H WHICH COMPUTES THE RED-BLACK INDEXING D / 1H , 10H IER = ,I5,12H IPARM(9) = ,I5,5H (NB) ) GO TO 160 C C ... PERMUTE MATRIX AND RHS C 43 IF (LEVEL .GE. 2) WRITE(NOUT,44) NB 44 FORMAT (/10X,27HORDER OF BLACK SUBSYSTEM = ,I5,5H (NB) ) CALL PERMAT (N,IA,JA,A,IWKSP,IWKSP(IB3),ISYM,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 46 IF (LEVEL .GE. 0) WRITE (NOUT,45) IER 45 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 40H WHICH DOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) GO TO 160 46 CALL PERVEC(N,RHS,IWKSP) CALL PERVEC(N,U,IWKSP) C C ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE C ... DIAGONAL ELEMENTS. C 50 CONTINUE CALL VFILL(IPARM(8),WKSP,0.0E0) CALL SCAL(N,IA,JA,A,RHS,U,WKSP,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 61 IF (LEVEL .GE. 0) WRITE(NOUT,60) IER 60 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE SCAL C / 1H , 30H WHICH SCALES THE SYSTEM D / 1H , 10H IER = ,I5) GO TO 160 61 IF (LEVEL .LE. 2) GO TO 64 WRITE (NOUT,63) 63 FORMAT(///1X,35HIN THE FOLLOWING, RHO AND GAMMA ARE A ,24H ACCELERATION PARAMETERS ) 64 IF(IPARM(11).NE.0)GO TO 68 ITIM1 = ITICK(NDUMMY) C C ... ITERATION SEQUENCE C 68 ITMAX1 = ITMAX + 1 DO 95 LOOP=1,ITMAX1 IN = LOOP - 1 IF (MOD(IN,2) .EQ. 1) GO TO 85 C C ... CODE FOR THE EVEN ITERATIONS. C C U = U(IN) C WKSP(IB1) = U(IN-1) C CALL ITJSI(N,IA,JA,A,RHS,U,WKSP(IB1),WKSP(IB2),ICNT) C IF (HALT) GO TO 132 GO TO 95 C C ... CODE FOR THE ODD ITERATIONS. C C U = U(IN-1) C WKSP(IB1) = U(IN) C 85 CALL ITJSI(N,IA,JA,A,RHS,WKSP(IB1),U,WKSP(IB2),ICNT) C IF (HALT) GO TO 132 95 CONTINUE C C ... ITMAX HAS BEEN REACHED C IF(IPARM(11).NE.0)GO TO 125 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 125 IER = 23 IF (LEVEL .GE. 1) WRITE(NOUT,130) ITMAX 130 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 25H IN ITPACK ROUTINE JSI B / 1H , 26H FAILURE TO CONVERGE IN ,I5, 11H ITERATIONS ) IF (IPARM(3) .EQ. 0) RPARM(1) = STPTST GO TO 140 C C ... METHOD HAS CONVERGED C 132 IF(IPARM(11).NE.0)GO TO 136 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 136 IF (LEVEL .GE. 1) WRITE(NOUT,138) IN 138 FORMAT(/1X,22HJSI HAS CONVERGED IN ,I5,11H ITERATIONS ) C C ... PUT SOLUTION INTO U IF NOT ALREADY THERE. C 140 CONTINUE IF (MOD(IN,2) .EQ. 1) CALL SCOPY(N,WKSP(IB1),1,U,1) C C ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. C CALL UNSCAL(N,IA,JA,A,RHS,U,WKSP) C C ... UN-PERMUTE MATRIX,RHS, AND SOLUTION C IF(IPARM(9) .LT. 0) GO TO 145 CALL PERMAT (N,IA,JA,A,IWKSP(IB2),IWKSP(IB3),ISYM, A LEVEL,NOUT,IERPER) IF (IERPER .EQ. 0) GO TO 144 IF (LEVEL .GE. 0) WRITE(NOUT,142) IERPER 142 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE JSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 45H WHICH UNDOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) IF(IER .EQ. 0) IER = IERPER GO TO 160 144 CALL PERVEC(N,RHS,IWKSP(IB2)) CALL PERVEC(N,U,IWKSP(IB2)) C C ... OPTIONAL ERROR ANALYSIS C 145 IDGTS = IPARM(12) IF(IDGTS .LT. 0) GO TO 150 IF(IPARM(2) .LE. 0) IDGTS = 0 CALL PERROR(N,IA,JA,A,RHS,U,WKSP,DIGIT1,DIGIT2,IDGTS) C C ... SET RETURN PARAMETERS IN IPARM AND RPARM C 150 IF(IPARM(11) .NE. 0) GO TO 155 JTIM2 = ITOCK(NDUMMY) TIME2 = AMAX0(0,JTIM2 - JTIM1)*1.E-3 155 IF (IPARM(3) .NE. 0) GO TO 160 IPARM(1) = IN IPARM(9) = NB RPARM(2) = CME RPARM(3) = SME RPARM(9) = TIME1 RPARM(10) = TIME2 RPARM(11) = DIGIT1 RPARM(12) = DIGIT2 C 160 CONTINUE IERR = IER IF (LEVEL .GE. 3) CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,2) C RETURN END SUBROUTINE SOR(NN,IA,JA,A,RHS,U,IWKSP,NW,WKSP, SOR 0010 A IPARM,RPARM,IERR) C C ITPACK 2C MAIN SUBROUTINE SOR (SUCCESSIVE OVERRELATION) C EACH OF THE MAIN SUBROUTINES: C JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI C CAN BE USED INDEPENDENTLY OF THE OTHERS C C ... FUNCTION: C C THIS SUBROUTINE, SOR, DRIVES THE SUCCESSIVE C OVERRELAXATION ALGORITHM. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS C THE LATEST ESTIMATE TO THE SOLUTION. C IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N C NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, C IPARM(8) IS AMOUNT USED. C WKSP REAL VECTOR USED FOR WORKING SPACE. SOR NEEDS THIS C TO BE IN LENGTH AT LEAST N C IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY C SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. C RPARM REAL VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME C REAL PARAMETERS WHICH AFFECT THE METHOD. C IER OUTPUT INTEGER. ERROR FLAG. (= IERR) C C ... SOR SUBPROGRAM REFERENCES: C C FROM ITPACK BISRCH, DFAULT, ECHALL, ECHOUT, IPSTR, ITERM, C ITICK, ITOCK, ITSOR, IVFILL, PERMAT, PERROR, C PERVEC, PFSOR1, PMULT, PRBNDX, PSTOP, QSORT, C SBELM, SCAL, SCOPY, SDOT, TAU, UNSCAL, VFILL, C VOUT, WEVMW C SYSTEM ABS, ALOG10, AMAX0, AMAX1, FLOAT, IABS, MOD, C SQRT C C VERSION: ITPACK 2C (MARCH 1982) C C CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS C CENTER FOR NUMERICAL ANALYSIS C UNIVERSITY OF TEXAS C AUSTIN, TX 78712 C (512) 471-1242 C C FOR ADDITIONAL DETAILS ON THE C (A) SUBROUTINE SEE TOMS ARTICLE 1982 C (B) ALGORITHM SEE CNA REPORT 150 C C BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN C C REFERENCE THE BOOK: APPLIED ITERATIVE METHODS C L. HAGEMAN, D. YOUNG C ACADEMIC PRESS, 1981 C C ************************************************** C * IMPORTANT NOTE * C * * C * WHEN INSTALLING ITPACK ROUTINES ON A * C * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * C * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * C * * C * SRELPR MACHINE RELATIVE PRECISION * C * RPARM(1) STOPPING CRITERION * C * * C * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * C * CPTIME USED IN ITICK AND ITOCK * C * * C ************************************************** C C C SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IWKSP(1), IPARM(12), A NN, NW, IERR REAL A(1), RHS(NN), U(NN), WKSP(NW), RPARM(12) C C SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB1, IB2, IB3, IDGTS, IER, IERPER, ITIM1, ITIM2, A ITMAX1, JTIM1, JTIM2, LOOP, N, NB, NDUMMY, N3 REAL DIGIT1, DIGIT2, TEMP, TIME1, TIME2, TOL C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C ... VARIABLES IN COMMON BLOCK - ITCOM1 C C IN - ITERATION NUMBER C IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED C ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C LEVEL - LEVEL OF OUTPUT CONTROL SWITCH C NOUT - OUTPUT UNIT NUMBER C C ... VARIABLES IN COMMON BLOCK - ITCOM2 C C ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH C BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA C CASEII - ADAPTIVE PROCEDURE CASE SWITCH C HALT - STOPPING TEST SWITCH C PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH C C ... VARIABLES IN COMMON BLOCK - ITCOM3 C C BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N C BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX C CME - ESTIMATE OF LARGEST EIGENVALUE C DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N C DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S C FF - ADAPTIVE PROCEDURE DAMPING FACTOR C GAMMA - ACCELERATION PARAMETER C OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR C QA - PSEUDO-RESIDUAL RATIO C QT - VIRTUAL SPECTRAL RADIUS C RHO - ACCELERATION PARAMETER C RRR - ADAPTIVE PARAMETER C SIGE - PARAMETER SIGMA-SUB-E C SME - ESTIMATE OF SMALLEST EIGENVALUE C SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR C SRELPR - MACHINE RELATIVE PRECISION C STPTST - STOPPING PARAMETER C UDNM - TWO NORM OF U C ZETA - STOPPING CRITERION C C C ... INITIALIZE COMMON BLOCKS C LEVEL = IPARM(2) NOUT = IPARM(4) IF (LEVEL .GE. 1) WRITE(NOUT,1) 1 FORMAT(1H0 ///1X,40HBEGINNING OF ITPACK SOLUTION MODULE SOR ) IER = 0 IF(IPARM(1) .LE. 0) RETURN N = NN IF(IPARM(11) .EQ. 0) JTIM1 = ITICK(NDUMMY) IF (LEVEL .GE. 3) GO TO 2 CALL ECHOUT(IPARM,RPARM,3) GO TO 3 2 CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,1) 3 TEMP = 5.0E2*SRELPR IF (ZETA .GE. TEMP) GO TO 5 IF (LEVEL .GE. 1) WRITE (NOUT,4) ZETA,SRELPR,TEMP 4 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 25H IN ITPACK ROUTINE SOR B / 1H , 14H RPARM(1) =,E10.3,7H (ZETA) C / 1H , 46H A VALUE THIS SMALL MAY HINDER CONVERGENCE D / 1H , 36H SINCE MACHINE PRECISION SRELPR = ,E10.3 E / 1H , 18H ZETA RESET TO ,E10.3) ZETA = TEMP 5 CONTINUE TIME1 = RPARM(9) TIME2 = RPARM(10) DIGIT1 = RPARM(11) DIGIT2 = RPARM(12) C C ... VERIFY N C IF(N .GT. 0 ) GO TO 15 IER = 31 IF (LEVEL .GE. 0) WRITE(NOUT,14) N 14 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE SOR B / 1H , 33H INVALID MATRIX DIMENSION, N =,I8) GO TO 160 15 CONTINUE C C ... REMOVE ROWS AND COLUMNS IF REQUESTED C IF(IPARM(10) .EQ. 0) GO TO 25 TOL = RPARM(8) CALL IVFILL(N,IWKSP,0) CALL VFILL(N,WKSP,0.0E0) CALL SBELM(N,IA,JA,A,RHS,IWKSP,WKSP,TOL,ISYM,LEVEL,NOUT,IER) IF(IER .EQ. 0) GO TO 25 IF (LEVEL .GE. 0) WRITE(NOUT,23) IER,TOL 23 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE SOR B / 1H , 40H ERROR DETECTED IN SUBROUTINE SBELM C / 1H , 45H WHICH REMOVES ROWS AND COLUMNS OF SYSTEM D / 1H , 35H WHEN DIAGONAL ENTRY TOO LARGE E / 1H , 10H IER = ,I5,5X,12H RPARM(8) = ,E10.3,6H (TOL) ) GO TO 160 C C ... INITIALIZE WKSP BASE ADDRESSES. C 25 IB1 = 1 IB2 = IB1 + N IB3 = IB2 + N IPARM(8) = N IF (NW .GE. IPARM(8)) GO TO 40 IER = 32 IF (LEVEL .GE. 0) WRITE(NOUT,30) NW,IPARM(8) 30 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE SOR B / 1H , 28H NOT ENOUGH WORKSPACE AT ,I10 C / 1H , 18H SET IPARM(8) =,I10,5H (NW) ) GO TO 160 C C ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED C 40 NB = IPARM(9) IF(NB .LT. 0) GO TO 50 N3 = 3*N CALL IVFILL(N3,IWKSP,0) CALL PRBNDX(N,NB,IA,JA,IWKSP,IWKSP(IB2),LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 43 IF (LEVEL .GE. 0) WRITE(NOUT,42) IER,NB 42 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE SOR B / 1H , 40H ERROR DETECTED IN SUBROUTINE PRBNDX C / 1H , 41H WHICH COMPUTES THE RED-BLACK INDEXING D / 1H , 10H IER = ,I5,12H IPARM(9) = ,I5,5H (NB) ) GO TO 160 C C ... PERMUTE MATRIX AND RHS C 43 IF (LEVEL .GE. 2) WRITE(NOUT,44) NB 44 FORMAT (/10X,27HORDER OF BLACK SUBSYSTEM = ,I5,5H (NB) ) CALL PERMAT (N,IA,JA,A,IWKSP,IWKSP(IB3),ISYM,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 46 IF (LEVEL .GE. 0) WRITE (NOUT,45) IER 45 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE SOR B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 40H WHICH DOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) GO TO 160 46 CALL PERVEC(N,RHS,IWKSP) CALL PERVEC(N,U,IWKSP) C C ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE C ... DIAGONAL ELEMENTS. C 50 CONTINUE CALL VFILL(IPARM(8),WKSP,0.0E0) CALL SCAL(N,IA,JA,A,RHS,U,WKSP,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 61 IF (LEVEL .GE. 0) WRITE(NOUT,60) IER 60 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE SOR B / 1H , 40H ERROR DETECTED IN SUBROUTINE SCAL C / 1H , 30H WHICH SCALES THE SYSTEM D / 1H , 10H IER = ,I5) GO TO 160 61 IF (LEVEL .LE. 2) GO TO 65 IF (ADAPT) WRITE (NOUT,62) 62 FORMAT(///1X,48HCME IS THE ESTIMATE OF THE LARGEST EIGENVALUE OF A ,18H THE JACOBI MATRIX ) WRITE(NOUT,64) 64 FORMAT(1X,30HOMEGA IS THE RELAXATION FACTOR ) 65 IF (IPARM(11).NE.0)GO TO 68 ITIM1 = ITICK(NDUMMY) C C ... ITERATION SEQUENCE C 68 ITMAX1 = ITMAX + 1 DO 95 LOOP=1,ITMAX1 IN = LOOP - 1 C C ... CODE FOR ONE ITERATION. C C U = U(IN) C CALL ITSOR(N,IA,JA,A,RHS,U,WKSP(IB1)) C IF (HALT) GO TO 132 95 CONTINUE C C ... ITMAX HAS BEEN REACHED C IF(IPARM(11).NE.0)GO TO 125 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 125 IF (LEVEL .GE. 1) WRITE(NOUT,130) ITMAX 130 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 25H IN ITPACK ROUTINE SOR B / 1H , 26H FAILURE TO CONVERGE IN ,I5, 11H ITERATIONS ) IER = 33 IF (IPARM(3) .EQ. 0) RPARM(1) = STPTST GO TO 140 C C ... METHOD HAS CONVERGED C 132 IF(IPARM(11).NE.0)GO TO 134 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 134 IF (LEVEL .GE. 1) WRITE(NOUT,136) IN 136 FORMAT(/1X,22HSOR HAS CONVERGED IN ,I5,11H ITERATIONS ) C C ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. C 140 CALL UNSCAL(N,IA,JA,A,RHS,U,WKSP) C C ... UN-PERMUTE MATRIX,RHS, AND SOLUTION C IF(IPARM(9) .LT. 0) GO TO 145 CALL PERMAT (N,IA,JA,A,IWKSP(IB2),IWKSP(IB3),ISYM, A LEVEL,NOUT,IERPER) IF (IERPER .EQ. 0) GO TO 144 IF (LEVEL .GE. 0) WRITE(NOUT,142) IERPER 142 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 35H CALLED FROM ITPACK ROUTINE SOR B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 45H WHICH UNDOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) IF(IER .EQ. 0) IER = IERPER GO TO 160 144 CALL PERVEC(N,RHS,IWKSP(IB2)) CALL PERVEC(N,U,IWKSP(IB2)) C C ... OPTIONAL ERROR ANALYSIS C 145 IDGTS = IPARM(12) IF(IDGTS .LT. 0) GO TO 150 IF(IPARM(2) .LE. 0) IDGTS = 0 CALL PERROR(N,IA,JA,A,RHS,U,WKSP,DIGIT1,DIGIT2,IDGTS) C C ... SET RETURN PARAMETERS IN IPARM AND RPARM C 150 IF(IPARM(11) .NE. 0) GO TO 155 JTIM2 = ITOCK(NDUMMY) TIME2 = AMAX0(0,JTIM2 - JTIM1)*1.E-3 155 IF (IPARM(3) .NE. 0) GO TO 160 IPARM(1) = IN IPARM(9) = NB RPARM(2) = CME RPARM(3) = SME RPARM(5) = OMEGA RPARM(9) = TIME1 RPARM(10) = TIME2 RPARM(11) = DIGIT1 RPARM(12) = DIGIT2 C 160 CONTINUE IERR = IER IF (LEVEL .GE. 3) CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,2) C RETURN END SUBROUTINE SSORCG(NN,IA,JA,A,RHS,U,IWKSP,NW,WKSP, SSOR0010 A IPARM,RPARM,IERR) C C ITPACK 2C MAIN SUBROUTINE SSORCG (SYMMETRIC SUCCESSIVE OVER- C RELAXATION CONJUGATE GRADIENT) C EACH OF THE MAIN SUBROUTINES: C JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI C CAN BE USED INDEPENDENTLY OF THE OTHERS C C ... FUNCTION: C C THIS SUBROUTINE, SSORCG, DRIVES THE SYMMETRIC SOR-CG C ALGORITHM. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS C THE LATEST ESTIMATE TO THE SOLUTION. C IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N C NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, C IPARM(8) IS AMOUNT USED. C WKSP REAL VECTOR USED FOR WORKING SPACE. SSOR-CG C NEEDS TO BE IN LENGTH AT LEAST C 6*N + 2*ITMAX, IF IPARM(5)=0 (SYMMETRIC STORAGE) C 6*N + 4*ITMAX, IF IPARM(5)=1 (NONSYMMETRIC STORAGE) C IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY C SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF C RPARM REAL VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME C REAL PARAMETERS WHICH AFFECT THE METHOD. C IER OUTPUT INTEGER. ERROR FLAG. (= IERR) C C ... SSORCG SUBPROGRAM REFERENCES: C C FROM ITPACK BISRCH, CHGCON, DETERM, DFAULT, ECHALL, C ECHOUT, EIGVNS, EIGVSS, EQRT1S, ITERM, ITICK, C ITOCK, ITSRCG, IVFILL, OMEG, OMGCHG, OMGSTR, C PARCON, PBETA, PBSOR, PERMAT, PERROR, C PERVEC, PFSOR, PMULT, PRBNDX, PSTOP, PVTBV, C QSORT, SBELM, SCAL, SCOPY, SDOT, SUM3, C UNSCAL, VEVMW, VEVPW, VFILL, VOUT, WEVMW, C ZBRENT C SYSTEM ABS, ALOG, ALOG10, AMAX0, AMAX1, AMIN1, C MOD, SQRT C C VERSION: ITPACK 2C (MARCH 1982) C C CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS C CENTER FOR NUMERICAL ANALYSIS C UNIVERSITY OF TEXAS C AUSTIN, TX 78712 C (512) 471-1242 C C FOR ADDITIONAL DETAILS ON THE C (A) SUBROUTINE SEE TOMS ARTICLE 1982 C (B) ALGORITHM SEE CNA REPORT 150 C C BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN C C REFERENCE THE BOOK: APPLIED ITERATIVE METHODS C L. HAGEMAN, D. YOUNG C ACADEMIC PRESS, 1981 C C C ************************************************** C * IMPORTANT NOTE * C * * C * WHEN INSTALLING ITPACK ROUTINES ON A * C * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * C * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * C * * C * SRELPR MACHINE RELATIVE PRECISION * C * RPARM(1) STOPPING CRITERION * C * * C * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * C * CPTIME USED IN ITICK AND ITOCK * C * * C ************************************************** C C SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IWKSP(1), IPARM(12), A NN, NW, IERR REAL A(1), RHS(NN), U(NN), WKSP(NW), RPARM(12) C C SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB1, IB2, IB3, IB4, IB5, IB6, IB7, IDGTS, IER, IERPER, A ITIM1, ITIM2, ITMAX1, JTIM1, JTIM2, LOOP, N, A NB, NDUMMY, N3 REAL BETNEW, DIGIT1, DIGIT2, TEMP, TIME1, TIME2, TOL C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C ... VARIABLES IN COMMON BLOCK - ITCOM1 C C IN - ITERATION NUMBER C IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED C ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C LEVEL - LEVEL OF OUTPUT CONTROL SWITCH C NOUT - OUTPUT UNIT NUMBER C C ... VARIABLES IN COMMON BLOCK - ITCOM2 C C ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH C BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA C CASEII - ADAPTIVE PROCEDURE CASE SWITCH C HALT - STOPPING TEST SWITCH C PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH C C ... VARIABLES IN COMMON BLOCK - ITCOM3 C C BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N C BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX C CME - ESTIMATE OF LARGEST EIGENVALUE C DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N C DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S C FF - ADAPTIVE PROCEDURE DAMPING FACTOR C GAMMA - ACCELERATION PARAMETER C OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR C QA - PSEUDO-RESIDUAL RATIO C QT - VIRTUAL SPECTRAL RADIUS C RHO - ACCELERATION PARAMETER C RRR - ADAPTIVE PARAMETER C SIGE - PARAMETER SIGMA-SUB-E C SME - ESTIMATE OF SMALLEST EIGENVALUE C SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR C SRELPR - MACHINE RELATIVE PRECISION C STPTST - STOPPING PARAMETER C UDNM - TWO NORM OF U C ZETA - STOPPING CRITERION C C C ... INITIALIZE COMMON BLOCKS C LEVEL = IPARM(2) NOUT = IPARM(4) IF (LEVEL .GE. 1) WRITE(NOUT,1) 1 FORMAT(1H0 ///1X,43HBEGINNING OF ITPACK SOLUTION MODULE SSORCG ) IER = 0 IF(IPARM(1) .LE. 0) RETURN N = NN IF(IPARM(11) .EQ. 0) JTIM1 = ITICK(NDUMMY) IF (LEVEL .GE. 3) GO TO 2 CALL ECHOUT(IPARM,RPARM,4) GO TO 3 2 CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,1) 3 TEMP = 5.0E2*SRELPR IF (ZETA .GE. TEMP) GO TO 5 IF (LEVEL .GE. 1) WRITE (NOUT,4) ZETA,SRELPR,TEMP 4 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 28H IN ITPACK ROUTINE SSORCG B / 1H , 14H RPARM(1) =,E10.3,7H (ZETA) C / 1H , 46H A VALUE THIS SMALL MAY HINDER CONVERGENCE D / 1H , 36H SINCE MACHINE PRECISION SRELPR = ,E10.3 E / 1H , 18H ZETA RESET TO ,E10.3) ZETA = TEMP 5 CONTINUE TIME1 = RPARM(9) TIME2 = RPARM(10) DIGIT1 = RPARM(11) DIGIT2 = RPARM(12) C C ... VERIFY N C IF(N .GT. 0 ) GO TO 15 IER = 41 IF (LEVEL .GE. 0) WRITE(NOUT,14) N 14 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORCG B / 1H , 33H INVALID MATRIX DIMENSION, N =,I8) GO TO 160 15 CONTINUE C C ... REMOVE ROWS AND COLUMNS IF REQUESTED C IF(IPARM(10) .EQ. 0) GO TO 20 TOL = RPARM(8) CALL IVFILL(N,IWKSP,0) CALL VFILL(N,WKSP,0.0E0) CALL SBELM(N,IA,JA,A,RHS,IWKSP,WKSP,TOL,ISYM,LEVEL,NOUT,IER) IF(IER .EQ. 0) GO TO 20 IF (LEVEL .GE. 0) WRITE(NOUT,23) IER,TOL 23 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE SBELM C / 1H , 45H WHICH REMOVES ROWS AND COLUMNS OF SYSTEM D / 1H , 35H WHEN DIAGONAL ENTRY TOO LARGE E / 1H , 10H IER = ,I5,5X,12H RPARM(8) = ,E10.3,6H (TOL) ) GO TO 160 C C ... INITIALIZE WKSP BASE ADDRESSES. C 20 IB1 = 1 IB2 = IB1 + N IB3 = IB2 + N IB4 = IB3 + N IB5 = IB4 + N IB6 = IB5 + N IB7 = IB6 + N IPARM(8) = 6*N + 2*ITMAX IF(ISYM .NE. 0) IPARM(8) = IPARM(8) + 2*ITMAX IF (NW .GE. IPARM(8)) GO TO 40 IER = 42 IF (LEVEL .GE. 0) WRITE(NOUT,30) NW,IPARM(8) 30 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORCG B / 1H , 28H NOT ENOUGH WORKSPACE AT ,I10 C / 1H , 18H SET IPARM(8) =,I10,5H (NW) ) GO TO 160 C C ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED C 40 NB = IPARM(9) IF(NB .LT. 0) GO TO 50 N3 = 3*N CALL IVFILL(N3,IWKSP,0) CALL PRBNDX(N,NB,IA,JA,IWKSP,IWKSP(IB2),LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 43 IF (LEVEL .GE. 0) WRITE(NOUT,42) IER,NB 42 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PRBNDX C / 1H , 41H WHICH COMPUTES THE RED-BLACK INDEXING D / 1H , 10H IER = ,I5,12H IPARM(9) = ,I5,5H (NB) ) GO TO 160 C C ... PERMUTE MATRIX AND RHS C 43 IF (LEVEL .GE. 2) WRITE(NOUT,44) NB 44 FORMAT (/10X,27HORDER OF BLACK SUBSYSTEM = ,I5,5H (NB) ) CALL PERMAT (N,IA,JA,A,IWKSP,IWKSP(IB3),ISYM,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 46 IF (LEVEL .GE. 0) WRITE (NOUT,45) IER 45 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 40H WHICH DOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) GO TO 160 46 CALL PERVEC(N,RHS,IWKSP) CALL PERVEC(N,U,IWKSP) C C ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE C ... DIAGONAL ELEMENTS. C 50 CONTINUE CALL VFILL(IPARM(8),WKSP,0.0E0) CALL SCAL(N,IA,JA,A,RHS,U,WKSP,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 61 IF (LEVEL .GE. 0) WRITE(NOUT,60) IER 60 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE SCAL C / 1H , 30H WHICH SCALES THE SYSTEM D / 1H , 10H IER = ,I5) GO TO 160 61 IF (LEVEL .LE. 2) GO TO 65 WRITE(NOUT,62) 62 FORMAT(///1X,35HIN THE FOLLOWING, RHO AND GAMMA ARE A ,24H ACCELERATION PARAMETERS ) WRITE(NOUT,63) 63 FORMAT(1X,42HS-PRIME IS AN INITIAL ESTIMATE FOR NEW CME ) 65 IF (IPARM(11).NE.0)GO TO 70 ITIM1 = ITICK(NDUMMY) C C ... SPECIAL PROCEDURE FOR FULLY ADAPTIVE CASE. C 70 CONTINUE IF (.NOT.ADAPT) GO TO 80 IF (.NOT.BETADT) GO TO 75 CALL VFILL(N,WKSP(IB1),1.E0) BETNEW = PBETA(N,IA,JA,A,WKSP(IB1),WKSP(IB2),WKSP(IB3) ) A / FLOAT(N) BETAB = AMAX1 ( BETAB, .25E0, BETNEW) 75 CALL OMEG(0.E0,1) IS = 0 C C ... INITIALIZE FORWARD PSEUDO-RESIDUAL C 80 CALL SCOPY(N,RHS,1,WKSP(IB1),1) CALL SCOPY(N,U,1,WKSP(IB2),1) CALL PFSOR(N,IA,JA,A,WKSP(IB2),WKSP(IB1)) CALL VEVMW(N,WKSP(IB2),U) C C ... ITERATION SEQUENCE C ITMAX1 = ITMAX + 1 DO 95 LOOP=1,ITMAX1 IN = LOOP - 1 IF (MOD(IN,2) .EQ. 1) GO TO 85 C C ... CODE FOR THE EVEN ITERATIONS. C C U = U(IN) WKSP(IB2) = C(IN) C WKSP(IB1) = U(IN-1) WKSP(IB3) = C(IN-1) C CALL ITSRCG(N,IA,JA,A,RHS,U,WKSP(IB1),WKSP(IB2),WKSP(IB3), A WKSP(IB4),WKSP(IB5),WKSP(IB6),WKSP(IB7)) C IF (HALT) GO TO 132 GO TO 95 C C ... CODE FOR THE ODD ITERATIONS. C C U = U(IN-1) WKSP(IB2) = C(IN-1) C WKSP(IB1) = U(IN) WKSP(IB3) =C(IN) C 85 CALL ITSRCG(N,IA,JA,A,RHS,WKSP(IB1),U,WKSP(IB3),WKSP(IB2), A WKSP(IB4),WKSP(IB5),WKSP(IB6),WKSP(IB7)) C IF (HALT) GO TO 132 95 CONTINUE C C ... ITMAX HAS BEEN REACHED C IF(IPARM(11).NE.0)GO TO 125 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 125 IF (LEVEL .GE. 1) WRITE(NOUT,130) ITMAX 130 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 28H IN ITPACK ROUTINE SSORCG B / 1H , 26H FAILURE TO CONVERGE IN ,I5, 11H ITERATIONS ) IER = 43 IF (IPARM(3) .EQ. 0) RPARM(1) = STPTST GO TO 140 C C ... METHOD HAS CONVERGED C 132 IF(IPARM(11).NE.0)GO TO 134 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 134 IF (LEVEL .GE. 1) WRITE(NOUT,136) IN 136 FORMAT(/1X,25HSSORCG HAS CONVERGED IN ,I5, A 11H ITERATIONS ) C C ... PUT SOLUTION INTO U IF NOT ALREADY THERE. C 140 CONTINUE IF (MOD(IN,2) .EQ. 1) CALL SCOPY(N,WKSP(IB1),1,U,1) C C ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. C CALL UNSCAL(N,IA,JA,A,RHS,U,WKSP) C C ... UN-PERMUTE MATRIX,RHS, AND SOLUTION C IF(IPARM(9) .LT. 0) GO TO 145 CALL PERMAT (N,IA,JA,A,IWKSP(IB2),IWKSP(IB3),ISYM, A LEVEL,NOUT,IERPER) IF (IERPER .EQ. 0) GO TO 144 IF (LEVEL .GE. 0) WRITE(NOUT,142) IERPER 142 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 45H WHICH UNDOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) IF(IER .EQ. 0) IER = IERPER GO TO 160 144 CALL PERVEC(N,RHS,IWKSP(IB2)) CALL PERVEC(N,U,IWKSP(IB2)) C C ... OPTIONAL ERROR ANALYSIS C 145 IDGTS = IPARM(12) IF(IDGTS .LT. 0) GO TO 150 IF(IPARM(2) .LE. 0) IDGTS = 0 CALL PERROR(N,IA,JA,A,RHS,U,WKSP,DIGIT1,DIGIT2,IDGTS) C C ... SET RETURN PARAMETERS IN IPARM AND RPARM C 150 IF(IPARM(11) .NE. 0) GO TO 155 JTIM2 = ITOCK(NDUMMY) TIME2 = AMAX0(0,JTIM2 - JTIM1)*1.E-3 155 IPARM(8) = IPARM(8) - 2 * (ITMAX - IN) IF(ISYM .NE. 0) IPARM(8) = IPARM(8) - 2*(ITMAX - IN) IF (IPARM(3) .NE. 0) GO TO 160 IPARM(1) = IN IPARM(9) = NB RPARM(2) = CME RPARM(3) = SME RPARM(5) = OMEGA RPARM(6) = SPECR RPARM(7) = BETAB RPARM(9) = TIME1 RPARM(10) = TIME2 RPARM(11) = DIGIT1 RPARM(12) = DIGIT2 C 160 CONTINUE IERR = IER IF (LEVEL .GE. 3) CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,2) C RETURN END SUBROUTINE SSORSI(NN,IA,JA,A,RHS,U,IWKSP,NW,WKSP, SSOR0010 A IPARM,RPARM,IERR) C C ITPACK 2C MAIN SUBROUTINE SSORSI (SYMMETRIC SUCCESSIVE RELAX- C ATION SEMI-ITERATION) C EACH OF THE MAIN SUBROUTINES: C JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI C CAN BE USED INDEPENDENTLY OF THE OTHERS C C ... FUNCTION: C C THIS SUBROUTINE, SSORSI, DRIVES THE SYMMETRIC SOR-SI C ALGORITHM. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS C THE LATEST ESTIMATE TO THE SOLUTION. C IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N C NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, C IPARM(8) IS AMOUNT USED. C WKSP REAL VECTOR USED FOR WORKING SPACE. SSORSI C NEEDS THIS TO BE IN LENGTH AT LEAST 5*N C IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY C SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF C RPARM REAL VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME C REAL PARAMETERS WHICH AFFECT THE METHOD. C IER OUTPUT INTEGER. ERROR FLAG. (= IERR) C C ... SSORSI SUBPROGRAM REFERENCES: C C FROM ITPACK BISRCH, CHEBY, CHGSI, DFAULT, ECHALL, ECHOUT, C ITERM, ITICK, ITOCK, ITSRSI, IVFILL, OMEG, C OMGSTR, PARSI, PBETA, PERMAT, PERROR, C PERVEC, PFSOR, PMULT, PRBNDX, PSSOR1, C PSTOP, PVTBV, QSORT, SBELM, SCAL, SCOPY, C SDOT, SUM3, TSTCHG, UNSCAL, VEVPW, VFILL, C VOUT, WEVMW C SYSTEM ABS, ALOG, ALOG10, AMAX0, AMAX1, FLOAT, C MOD, SQRT C C VERSION: ITPACK 2C (MARCH 1982) C C CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS C CENTER FOR NUMERICAL ANALYSIS C UNIVERSITY OF TEXAS C AUSTIN, TX 78712 C (512) 471-1242 C C FOR ADDITIONAL DETAILS ON THE C (A) SUBROUTINE SEE TOMS ARTICLE 1982 C (B) ALGORITHM SEE CNA REPORT 150 C C BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN C C REFERENCE THE BOOK: APPLIED ITERATIVE METHODS C L. HAGEMAN, D. YOUNG C ACADEMIC PRESS, 1981 C C ************************************************** C * IMPORTANT NOTE * C * * C * WHEN INSTALLING ITPACK ROUTINES ON A * C * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * C * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * C * * C * SRELPR MACHINE RELATIVE PRECISION * C * RPARM(1) STOPPING CRITERION * C * * C * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * C * CPTIME USED IN ITICK AND ITOCK * C * * C ************************************************** C C C SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IWKSP(1), IPARM(12), A NN, NW, IERR REAL A(1), RHS(NN), U(NN), WKSP(NW), RPARM(12) C C SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB1, IB2, IB3, IB4, IB5, IDGTS, IER, IERPER, ITIM1, A ITIM2, ITMAX1, JTIM1, JTIM2, LOOP, N, NB, NDUMMY, N3 REAL BETNEW, DIGIT1, DIGIT2, TEMP, TIME1, TIME2, TOL C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C ... VARIABLES IN COMMON BLOCK - ITCOM1 C C IN - ITERATION NUMBER C ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH C IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C LEVEL - LEVEL OF OUTPUT CONTROL SWITCH C NOUT - OUTPUT UNIT NUMBER C C ... VARIABLES IN COMMON BLOCK - ITCOM2 C C ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH C BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA C CASEII - ADAPTIVE PROCEDURE CASE SWITCH C HALT - STOPPING TEST SWITCH C PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH C C ... VARIABLES IN COMMON BLOCK - ITCOM3 C C BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N C BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX C CME - ESTIMATE OF LARGEST EIGENVALUE C DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N C DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S C FF - ADAPTIVE PROCEDURE DAMPING FACTOR C GAMMA - ACCELERATION PARAMETER C OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR C QA - PSEUDO-RESIDUAL RATIO C QT - VIRTUAL SPECTRAL RADIUS C RHO - ACCELERATION PARAMETER C RRR - ADAPTIVE PARAMETER C SIGE - PARAMETER SIGMA-SUB-E C SME - ESTIMATE OF SMALLEST EIGENVALUE C SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR C SRELPR - MACHINE RELATIVE PRECISION C STPTST - STOPPING PARAMETER C UDNM - TWO NORM OF U C ZETA - STOPPING CRITERION C C C ... INITIALIZE COMMON BLOCKS C LEVEL = IPARM(2) NOUT = IPARM(4) IF (LEVEL .GE. 1) WRITE(NOUT,1) 1 FORMAT(1H0 ///1X,43HBEGINNING OF ITPACK SOLUTION MODULE SSORSI ) IER = 0 IF(IPARM(1) .LE. 0) RETURN N = NN IF(IPARM(11) .EQ. 0) JTIM1 = ITICK(NDUMMY) IF (LEVEL .GE. 3) GO TO 2 CALL ECHOUT(IPARM,RPARM,5) GO TO 3 2 CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,1) 3 TEMP = 5.0E2*SRELPR IF (ZETA .GE. TEMP) GO TO 5 IF (LEVEL .GE. 1) WRITE (NOUT,4) ZETA,SRELPR,TEMP 4 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 28H IN ITPACK ROUTINE SSORSI B / 1H , 14H RPARM(1) =,E10.3,7H (ZETA) C / 1H , 46H A VALUE THIS SMALL MAY HINDER CONVERGENCE D / 1H , 36H SINCE MACHINE PRECISION SRELPR = ,E10.3 E / 1H , 18H ZETA RESET TO ,E10.3) ZETA = TEMP 5 CONTINUE TIME1 = RPARM(9) TIME2 = RPARM(10) DIGIT1 = RPARM(11) DIGIT2 = RPARM(12) C C ... VERIFY N C IF(N .GT. 0 ) GO TO 15 IER = 51 IF (LEVEL .GE. 0) WRITE(NOUT,14) N 14 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORSI B / 1H , 33H INVALID MATRIX DIMENSION, N =,I8) GO TO 160 15 CONTINUE C C ... REMOVE ROWS AND COLUMNS IF REQUESTED C IF(IPARM(10) .EQ. 0) GO TO 20 TOL = RPARM(8) CALL IVFILL(N,IWKSP,0) CALL VFILL(N,WKSP,0.0E0) CALL SBELM(N,IA,JA,A,RHS,IWKSP,WKSP,TOL,ISYM,LEVEL,NOUT,IER) IF(IER .EQ. 0) GO TO 20 IF (LEVEL .GE. 0) WRITE(NOUT,23) IER,TOL 23 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE SBELM C / 1H , 45H WHICH REMOVES ROWS AND COLUMNS OF SYSTEM D / 1H , 35H WHEN DIAGONAL ENTRY TOO LARGE E / 1H , 10H IER = ,I5,5X,12H RPARM(8) = ,E10.3,6H (TOL) ) GO TO 160 C C ... INITIALIZE WKSP BASE ADDRESSES. C 20 IB1 = 1 IB2 = IB1 + N IB3 = IB2 + N IB4 = IB3 + N IB5 = IB4 + N IPARM(8) = 5*N IF (NW .GE. IPARM(8)) GO TO 40 IER = 52 IF (LEVEL .GE. 0) WRITE(NOUT,30) NW,IPARM(8) 30 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORSI B / 1H , 28H NOT ENOUGH WORKSPACE AT ,I10 C / 1H , 18H SET IPARM(8) =,I10,5H (NW) ) C C ... PERMUTE TO RED-BLACK SYSTEM IF REQUESTED C 40 NB = IPARM(9) IF(NB .LT. 0) GO TO 50 N3 = 3*N CALL IVFILL(N3,IWKSP,0) CALL PRBNDX(N,NB,IA,JA,IWKSP,IWKSP(IB2),LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 43 IF (LEVEL .GE. 0) WRITE(NOUT,42) IER,NB 42 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PRBNDX C / 1H , 41H WHICH COMPUTES THE RED-BLACK INDEXING D / 1H , 10H IER = ,I5,12H IPARM(9) = ,I5,5H (NB) ) GO TO 160 C C ... PERMUTE MATRIX AND RHS C 43 IF (LEVEL .GE. 2) WRITE(NOUT,44) NB 44 FORMAT (/10X,27HORDER OF BLACK SUBSYSTEM = ,I5,5H (NB) ) CALL PERMAT (N,IA,JA,A,IWKSP,IWKSP(IB3),ISYM,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 46 IF (LEVEL .GE. 0) WRITE (NOUT,45) IER 45 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 40H WHICH DOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) GO TO 160 46 CALL PERVEC(N,RHS,IWKSP) CALL PERVEC(N,U,IWKSP) C C ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE C ... DIAGONAL ELEMENTS. C 50 CONTINUE CALL VFILL(IPARM(8),WKSP,0.0E0) CALL SCAL(N,IA,JA,A,RHS,U,WKSP,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 61 IF (LEVEL .GE. 0) WRITE(NOUT,60) IER 60 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE SCAL C / 1H , 30H WHICH SCALES THE SYSTEM D / 1H , 10H IER = ,I5) GO TO 160 61 IF (LEVEL .LE. 2) GO TO 65 WRITE(NOUT,62) 62 FORMAT(///1X,35HIN THE FOLLOWING, RHO AND GAMMA ARE A ,24H ACCELERATION PARAMETERS ) 65 IF (IPARM(11).NE.0)GO TO 70 ITIM1 = ITICK(NDUMMY) C C ... SPECIAL PROCEDURE FOR FULLY ADAPTIVE CASE. C 70 CONTINUE IF (.NOT.ADAPT) GO TO 80 IF (.NOT.BETADT) GO TO 75 CALL VFILL(N,WKSP(IB1),1.E0) BETNEW = PBETA(N,IA,JA,A,WKSP(IB1),WKSP(IB2),WKSP(IB3) ) A / FLOAT(N) BETAB = AMAX1 ( BETAB, .25E0, BETNEW) 75 CALL OMEG(0.E0,1) IS = 0 C C ... ITERATION SEQUENCE C 80 ITMAX1 = ITMAX + 1 DO 95 LOOP=1,ITMAX1 IN = LOOP - 1 IF (MOD(IN,2) .EQ. 1) GO TO 85 C C ... CODE FOR THE EVEN ITERATIONS. C C U = U(IN) C WKSP(IB1) = U(IN-1) C CALL ITSRSI(N,IA,JA,A,RHS,U,WKSP(IB1),WKSP(IB2),WKSP(IB3), A WKSP(IB4),WKSP(IB5)) C IF (HALT) GO TO 132 GO TO 95 C C ... CODE FOR THE ODD ITERATIONS. C C U = U(IN-1) C WKSP(IB1) = U(IN) C 85 CALL ITSRSI(N,IA,JA,A,RHS,WKSP(IB1),U,WKSP(IB2),WKSP(IB3), A WKSP(IB4),WKSP(IB5)) C IF (HALT) GO TO 132 95 CONTINUE C C ... ITMAX HAS BEEN REACHED C IF(IPARM(11).NE.0)GO TO 125 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 125 IF (LEVEL .GE. 1) WRITE(NOUT,130) ITMAX 130 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 28H IN ITPACK ROUTINE SSORSI B / 1H , 26H FAILURE TO CONVERGE IN ,I5, 11H ITERATIONS ) IER = 53 IF (IPARM(3) .EQ. 0) RPARM(1) = STPTST GO TO 140 C C ... METHOD HAS CONVERGED C 132 IF(IPARM(11) .NE. 0)GO TO 134 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 134 IF (LEVEL .GE. 1) WRITE(NOUT,136) IN 136 FORMAT(/1X,25HSSORSI HAS CONVERGED IN ,I5,11H ITERATIONS ) C C ... PUT SOLUTION INTO U IF NOT ALREADY THERE. C 140 CONTINUE IF (MOD(IN,2) .EQ. 1) CALL SCOPY(N,WKSP(IB1),1,U,1) C C ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. C CALL UNSCAL(N,IA,JA,A,RHS,U,WKSP) C C ... UN-PERMUTE MATRIX,RHS, AND SOLUTION C IF(IPARM(9) .LT. 0) GO TO 145 CALL PERMAT (N,IA,JA,A,IWKSP(IB2),IWKSP(IB3),ISYM, A LEVEL,NOUT,IERPER) IF (IERPER .EQ. 0) GO TO 144 IF (LEVEL .GE. 0) WRITE(NOUT,142) IERPER 142 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 38H CALLED FROM ITPACK ROUTINE SSORSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 45H WHICH UNDOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) IF(IER .EQ. 0) IER = IERPER GO TO 160 144 CALL PERVEC(N,RHS,IWKSP(IB2)) CALL PERVEC(N,U,IWKSP(IB2)) C C ... OPTIONAL ERROR ANALYSIS C 145 IDGTS = IPARM(12) IF(IDGTS .LT. 0) GO TO 150 IF(IPARM(2) .LE. 0) IDGTS = 0 CALL PERROR(N,IA,JA,A,RHS,U,WKSP,DIGIT1,DIGIT2,IDGTS) C C ... SET RETURN PARAMETERS IN IPARM AND RPARM C 150 IF (IPARM(11) .NE. 0) GO TO 155 JTIM2 = ITOCK(NDUMMY) TIME2 = AMAX0(0,JTIM2 - JTIM1)*1.E-3 155 IF (IPARM(3) .NE. 0) GO TO 160 IPARM(1) = IN IPARM(9) = NB RPARM(2) = CME RPARM(3) = SME RPARM(5) = OMEGA RPARM(6) = SPECR RPARM(7) = BETAB RPARM(9) = TIME1 RPARM(10) = TIME2 RPARM(11) = DIGIT1 RPARM(12) = DIGIT2 C 160 CONTINUE IERR = IER IF (LEVEL .GE. 3) CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,2) C RETURN END SUBROUTINE RSCG(NN,IA,JA,A,RHS,U,IWKSP,NW,WKSP, RSCG0010 A IPARM,RPARM,IERR) C C ITPACK 2C MAIN SUBROUTINE RSCG (REDUCED SYSTEM CONJUGATE C GRADIENT) C EACH OF THE MAIN SUBROUTINES: C JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI C CAN BE USED INDEPENDENTLY OF THE OTHERS C C C ... FUNCTION: C C THIS SUBROUTINE, RSCG, DRIVES THE REDUCED SYSTEM CG C ALGORITHM. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IN THE RED-BLACK MATRIX. C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS C THE LATEST ESTIMATE TO THE SOLUTION. C IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N C NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, C IPARM(8) IS AMOUNT USED. C WKSP REAL VECTOR USED FOR WORKING SPACE. RSCG NEEDS C THIS TO BE IN LENGTH AT LEAST C N+3*NB+2*ITMAX, IF IPARM(5)=0 (SYMMETRIC STORAGE) C N+3*NB+4*ITMAX, IF IPARM(5)=1 (NONSYMMETRIC STORAGE) C HERE NB IS THE ORDER OF THE BLACK SUBSYSTEM C IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY C SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF C RPARM REAL VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME C REAL PARAMETERS WHICH AFFECT THE METHOD. C IER OUTPUT INTEGER. ERROR FLAG. (= IERR) C C ... RSCG SUBPROGRAM REFERENCES: C C FROM ITPACK BISRCH, CHGCON, DETERM, DFAULT, ECHALL, C ECHOUT, EIGVNS, EIGVSS, EQRT1S, ITERM, ITICK C ITOCK, ITRSCG, IVFILL, PARCON, PERMAT, C PERROR, PERVEC, PMULT, PRBNDX, PRSBLK, C PRSRED, PSTOP, QSORT, SBELM, SCAL, SCOPY, C SDOT, SUM3, UNSCAL, VFILL, VOUT, WEVMW, C ZBRENT C SYSTEM ABS, ALOG10, AMAX0, AMAX1, MOD, SQRT C C VERSION: ITPACK 2C (MARCH 1982) C C CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS C CENTER FOR NUMERICAL ANALYSIS C UNIVERSITY OF TEXAS C AUSTIN, TX 78712 C (512) 471-1242 C C FOR ADDITIONAL DETAILS ON THE C (A) SUBROUTINE SEE TOMS ARTICLE 1982 C (B) ALGORITHM SEE CNA REPORT 150 C C BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN C C REFERENCE THE BOOK: APPLIED ITERATIVE METHODS C L. HAGEMAN, D. YOUNG C ACADEMIC PRESS, 1981 C C C ************************************************** C * IMPORTANT NOTE * C * * C * WHEN INSTALLING ITPACK ROUTINES ON A * C * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * C * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * C * * C * SRELPR MACHINE RELATIVE PRECISION * C * RPARM(1) STOPPING CRITERION * C * * C * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * C * CPTIME USED IN ITICK AND ITOCK * C * * C ************************************************** C C SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IWKSP(1), IPARM(12), A NN, NW, IERR REAL A(1), RHS(NN), U(NN), WKSP(NW), RPARM(12) C C SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB1, IB2, IB3, IB4, IB5, IDGTS, IER, IERPER, ITIM1, ITIM2, A ITMAX1, JB3, JTIM1, JTIM2, LOOP, N, NB, NDUMMY, A NR, NRP1, N3 REAL DIGIT1, DIGIT2, TEMP, TIME1, TIME2, TOL C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C ... VARIABLES IN COMMON BLOCK - ITCOM1 C C IN - ITERATION NUMBER C IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED C ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C LEVEL - LEVEL OF OUTPUT CONTROL SWITCH C NOUT - OUTPUT UNIT NUMBER C C ... VARIABLES IN COMMON BLOCK - ITCOM2 C C ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH C BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA C CASEII - ADAPTIVE PROCEDURE CASE SWITCH C HALT - STOPPING TEST SWITCH C PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH C C ... VARIABLES IN COMMON BLOCK - ITCOM3 C C BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N C BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX C CME - ESTIMATE OF LARGEST EIGENVALUE C DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N C DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S C FF - ADAPTIVE PROCEDURE DAMPING FACTOR C GAMMA - ACCELERATION PARAMETER C OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR C QA - PSEUDO-RESIDUAL RATIO C QT - VIRTUAL SPECTRAL RADIUS C RHO - ACCELERATION PARAMETER C RRR - ADAPTIVE PARAMETER C SIGE - PARAMETER SIGMA-SUB-E C SME - ESTIMATE OF SMALLEST EIGENVALUE C SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR C SRELPR - MACHINE RELATIVE PRECISION C STPTST - STOPPING PARAMETER C UDNM - TWO NORM OF U C ZETA - STOPPING CRITERION C C C ... INITIALIZE COMMON BLOCKS C LEVEL = IPARM(2) NOUT = IPARM(4) IF (LEVEL .GE. 1) WRITE(NOUT,1) 1 FORMAT(1H0 ///1X,41HBEGINNING OF ITPACK SOLUTION MODULE RSCG ) IER = 0 IF(IPARM(1) .LE. 0) RETURN N = NN IF(IPARM(11) .EQ. 0) JTIM1 = ITICK(NDUMMY) IF (LEVEL .GE. 3) GO TO 2 CALL ECHOUT(IPARM,RPARM,6) GO TO 3 2 CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,1) 3 TEMP = 5.0E2*SRELPR IF (ZETA .GE. TEMP) GO TO 5 IF (LEVEL .GE. 1) WRITE (NOUT,4) ZETA,SRELPR,TEMP 4 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 26H IN ITPACK ROUTINE RSCG B / 1H , 14H RPARM(1) =,E10.3,7H (ZETA) C / 1H , 46H A VALUE THIS SMALL MAY HINDER CONVERGENCE D / 1H , 36H SINCE MACHINE PRECISION SRELPR = ,E10.3 E / 1H , 18H ZETA RESET TO ,E10.3) ZETA = TEMP 5 CONTINUE TIME1 = RPARM(9) TIME2 = RPARM(10) DIGIT1 = RPARM(11) DIGIT2 = RPARM(12) C C ... VERIFY N C IF(N .GT. 0 ) GO TO 15 IER = 61 IF (LEVEL .GE. 0) WRITE(NOUT,14) N 14 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSCG B / 1H , 33H INVALID MATRIX DIMENSION, N =,I8) GO TO 160 15 CONTINUE C C ... REMOVE ROWS AND COLUMNS IF REQUESTED C IF(IPARM(10) .EQ. 0) GO TO 25 TOL = RPARM(8) CALL IVFILL(N,IWKSP,0) CALL VFILL(N,WKSP,0.0E0) CALL SBELM(N,IA,JA,A,RHS,IWKSP,WKSP,TOL,ISYM,LEVEL,NOUT,IER) IF(IER .EQ. 0) GO TO 25 IF (LEVEL .GE. 0) WRITE(NOUT,23) IER,TOL 23 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE SBELM C / 1H , 45H WHICH REMOVES ROWS AND COLUMNS OF SYSTEM D / 1H , 35H WHEN DIAGONAL ENTRY TOO LARGE E / 1H , 10H IER = ,I5,5X,12H RPARM(8) = ,E10.3,6H (TOL) ) GO TO 160 C C ... INITIALIZE WKSP BASE ADDRESSES. C 25 IB1 = 1 IB2 = IB1 + N JB3 = IB2 + N C C ... PERMUTE TO RED-BLACK SYSTEM IF POSSIBLE C NB = IPARM(9) IF(NB .GE. 0) GO TO 35 N3 = 3*N CALL IVFILL(N3,IWKSP,0) CALL PRBNDX(N,NB,IA,JA,IWKSP,IWKSP(IB2),LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 35 IF (LEVEL .GE. 0) WRITE(NOUT,30) IER,NB 30 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PRBNDX C / 1H , 41H WHICH COMPUTES THE RED-BLACK INDEXING D / 1H , 10H IER = ,I5,12H IPARM(9) = ,I5,5H (NB) ) GO TO 160 35 IF (NB .GE. 0 .AND. NB .LE. N) GO TO 43 IER = 64 IF (LEVEL .GE. 1) WRITE(NOUT,37) IER,NB 37 FORMAT(/10X,43HERROR DETECTED IN RED-BLACK SUBSYSTEM INDEX A /10X,5HIER =,I5,11H IPARM(9) =,I5,5H (NB) ) GO TO 160 43 IF (NB.NE.0 .AND. NB.NE.N) GO TO 45 NB = N/2 IF (LEVEL.GE.2 .AND. IPARM(9).GE.0) WRITE(NOUT,44) A IPARM(9),NB 44 FORMAT(/10X,12H IPARM(9) = ,I5,27H IMPLIES MATRIX IS DIAGONAL A /10X,13H NB RESET TO ,I5) C C ... PERMUTE MATRIX AND RHS C 45 IF(IPARM(9) .GE. 0) GO TO 51 IF (LEVEL .GE. 2) WRITE(NOUT,46) NB 46 FORMAT (/10X,27HORDER OF BLACK SUBSYSTEM = ,I5,5H (NB) ) CALL PERMAT (N,IA,JA,A,IWKSP,IWKSP(JB3),ISYM,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 48 IF (LEVEL .GE. 0) WRITE (NOUT,47) IER 47 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 40H WHICH DOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) GO TO 160 48 CALL PERVEC(N,RHS,IWKSP) CALL PERVEC(N,U,IWKSP) C C ... FINISH WKSP BASE ADDRESSES C 51 IB3 = IB2 + NB IB4 = IB3 + NB IB5 = IB4 + NB NR = N - NB NRP1 = NR + 1 IPARM(8) = N + 3*NB + 2*ITMAX IF(ISYM .NE. 0) IPARM(8) = IPARM(8) + 2*ITMAX IF (NW .GE. IPARM(8)) GO TO 55 IER = 62 IF (LEVEL .GE. 0) WRITE(NOUT,53) NW,IPARM(8) 53 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSCG B / 1H , 28H NOT ENOUGH WORKSPACE AT ,I10 C / 1H , 18H SET IPARM(8) =,I10,5H (NW) ) GO TO 160 C C ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE C ... DIAGONAL ELEMENTS. C 55 CONTINUE CALL VFILL(IPARM(8),WKSP,0.0E0) CALL SCAL(N,IA,JA,A,RHS,U,WKSP,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 61 IF (LEVEL .GE. 0) WRITE(NOUT,60) IER 60 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE SCAL C / 1H , 30H WHICH SCALES THE SYSTEM D / 1H , 10H IER = ,I5) GO TO 160 61 IF (LEVEL .LE. 2) GO TO 65 WRITE(NOUT,62) 62 FORMAT(///1X,35HIN THE FOLLOWING, RHO AND GAMMA ARE A ,24H ACCELERATION PARAMETERS ) IF (ADAPT) WRITE(NOUT,63) 63 FORMAT(1X,48HCME IS THE ESTIMATE OF THE LARGEST EIGENVALUE OF A ,18H THE JACOBI MATRIX ) 65 IF (IPARM(11).NE.0)GO TO 75 ITIM1 = ITICK(NDUMMY) C C ... INITIALIZE FORWARD PSEUDO-RESIDUAL C 75 CONTINUE IF (N .GT. 1) GO TO 76 U(1) = RHS(1) GO TO 132 76 CALL SCOPY(NR,RHS,1,WKSP(IB1),1) CALL PRSRED(NB,NR,IA,JA,A,U(NRP1),WKSP(IB1)) CALL SCOPY(NB,RHS(NRP1),1,WKSP(IB2),1) CALL PRSBLK(NB,NR,IA,JA,A,WKSP(IB1),WKSP(IB2)) CALL VEVMW(NB,WKSP(IB2),U(NRP1)) C C ... ITERATION SEQUENCE C ITMAX1 = ITMAX + 1 DO 95 LOOP=1,ITMAX1 IN = LOOP - 1 IF (MOD(IN,2) .EQ. 1) GO TO 85 C C ... CODE FOR THE EVEN ITERATIONS. C C U = U(IN) WKSP(IB2) = D(IN) C WKSP(IB1) = U(IN-1) WKSP(IB3) = D(IN-1) C CALL ITRSCG(N,NB,IA,JA,A,U,WKSP(IB1),WKSP(IB2),WKSP(IB3), A WKSP(IB4),WKSP(IB5) ) C IF (HALT) GO TO 132 GO TO 95 C C ... CODE FOR THE ODD ITERATIONS. C C U = U(IN-1) WKSP(IB2) = D(IN-1) C WKSP(IB1) = U(IN) WKSP(IB3) = D(IN) C 85 CALL ITRSCG(N,NB,IA,JA,A,WKSP(IB1),U,WKSP(IB3),WKSP(IB2), A WKSP(IB4),WKSP(IB5) ) C IF (HALT) GO TO 132 95 CONTINUE C C ... ITMAX HAS BEEN REACHED C IF (IPARM(11) .NE. 0) GO TO 125 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 125 IF (LEVEL .GE. 1) WRITE(NOUT,130) ITMAX 130 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 26H IN ITPACK ROUTINE RSCG B / 1H , 26H FAILURE TO CONVERGE IN ,I5, 11H ITERATIONS ) IER = 63 IF (IPARM(3) .EQ. 0) RPARM(1) = STPTST GO TO 140 C C ... METHOD HAS CONVERGED C 132 IF (IPARM(11) .NE. 0) GO TO 134 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 134 IF (LEVEL .GE. 1) WRITE(NOUT,136) IN 136 FORMAT(/1X,23HRSCG HAS CONVERGED IN ,I5,11H ITERATIONS ) C C ... PUT SOLUTION INTO U IF NOT ALREADY THERE. C 140 CONTINUE IF (N .EQ. 1) GO TO 142 IF (MOD(IN,2) .EQ. 1) CALL SCOPY(N,WKSP(IB1),1,U,1) CALL SCOPY(NR,RHS,1,U,1) CALL PRSRED(NB,NR,IA,JA,A,U(NRP1),U) C C ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. C 142 CALL UNSCAL(N,IA,JA,A,RHS,U,WKSP) C C ... UN-PERMUTE MATRIX,RHS, AND SOLUTION C IF(IPARM(9) .GE. 0) GO TO 145 CALL PERMAT (N,IA,JA,A,IWKSP(IB2),IWKSP(JB3),ISYM, A LEVEL,NOUT,IERPER) IF (IERPER .EQ. 0) GO TO 144 IF (LEVEL .GE. 0) WRITE(NOUT,143) IERPER 143 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSCG B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 45H WHICH UNDOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) IF(IER .EQ. 0) IER = IERPER GO TO 160 144 CALL PERVEC(N,RHS,IWKSP(IB2)) CALL PERVEC(N,U,IWKSP(IB2)) C C ... OPTIONAL ERROR ANALYSIS C 145 IDGTS = IPARM(12) IF(IDGTS .LT. 0) GO TO 150 IF(IPARM(2) .LE. 0) IDGTS = 0 CALL PERROR(N,IA,JA,A,RHS,U,WKSP,DIGIT1,DIGIT2,IDGTS) C C ... SET RETURN PARAMETERS IN IPARM AND RPARM C 150 IF(IPARM(11) .NE. 0) GO TO 155 JTIM2 = ITOCK(NDUMMY) TIME2 = AMAX0(0,JTIM2 - JTIM1)*1.E-3 155 IPARM(8) = IPARM(8) - 2 * (ITMAX - IN) IF(ISYM .NE. 0) IPARM(8) = IPARM(8) - 2*(ITMAX - IN) IF (IPARM(3) .NE. 0) GO TO 160 IPARM(1) = IN IPARM(9) = NB RPARM(2) = CME RPARM(3) = SME RPARM(9) = TIME1 RPARM(10) = TIME2 RPARM(11) = DIGIT1 RPARM(12) = DIGIT2 C 160 CONTINUE IERR = IER IF (LEVEL .GE. 3) CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,2) C RETURN END SUBROUTINE RSSI(NN,IA,JA,A,RHS,U,IWKSP,NW,WKSP, RSSI0010 A IPARM,RPARM,IERR) C C ITPACK 2C MAIN SUBROUTINE RSSI (REDUCED SYSTEM SEMI-ITERATIVE) C EACH OF THE MAIN SUBROUTINES: C JCG, JSI, SOR, SSORCG, SSORSI, RSCG, RSSI C CAN BE USED INDEPENDENTLY OF THE OTHERS C C ... FUNCTION: C C THIS SUBROUTINE, RSSI, DRIVES THE REDUCED SYSTEM SI C ALGORITHM. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C INITIAL GUESS TO THE SOLUTION. ON OUTPUT, IT CONTAINS C THE LATEST ESTIMATE TO THE SOLUTION. C IWKSP INTEGER VECTOR WORKSPACE OF LENGTH 3*N C NW INPUT INTEGER. LENGTH OF AVAILABLE WKSP. ON OUTPUT, C IPARM(8) IS AMOUNT USED. C WKSP REAL VECTOR USED FOR WORKING SPACE. RSSI C NEEDS THIS TO BE IN LENGTH AT LEAST N + NB C HERE NB IS THE ORDER OF THE BLACK SUBSYSTEM C IPARM INTEGER VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY C SOME INTEGER PARAMETERS WHICH AFFECT THE METHOD. IF C RPARM REAL VECTOR OF LENGTH 12. ALLOWS USER TO SPECIFY SOME C REAL PARAMETERS WHICH AFFECT THE METHOD. C IER OUTPUT INTEGER. ERROR FLAG. (= IERR) C C ... RSSI SUBPROGRAM REFERENCES: C C FROM ITPACK BISRCH, CHEBY, CHGSI, DFAULT, ECHALL, C ECHOUT, ITERM, ITICK, ITOCK, ITRSSI, IVFILL, C PARSI, PERMAT, PERROR, PERVEC, PMULT, C PRBNDX, PRSBLK, PRSRED, PSTOP, QSORT, C SAXPY, SBELM, SCAL, SCOPY, SDOT, SUM3, C TSTCHG, UNSCAL, VEVMW, VFILL, VOUT, C WEVMW C SYSTEM ABS, ALOG10, AMAX0, AMAX1, FLOAT, MOD C SQRT C C VERSION: ITPACK 2C (MARCH 1982) C C CODE WRITTEN BY: DAVID KINCAID, ROGER GRIMES, JOHN RESPESS C CENTER FOR NUMERICAL ANALYSIS C UNIVERSITY OF TEXAS C AUSTIN, TX 78712 C (512) 471-1242 C C FOR ADDITIONAL DETAILS ON THE C (A) SUBROUTINE SEE TOMS ARTICLE 1982 C (B) ALGORITHM SEE CNA REPORT 150 C C BASED ON THEORY BY: DAVID YOUNG, DAVID KINCAID, LOU HAGEMAN C C REFERENCE THE BOOK: APPLIED ITERATIVE METHODS C L. HAGEMAN, D. YOUNG C ACADEMIC PRESS, 1981 C C ************************************************** C * IMPORTANT NOTE * C * * C * WHEN INSTALLING ITPACK ROUTINES ON A * C * DIFFERENT COMPUTER, RESET SOME OF THE VALUES * C * IN SUBROUTNE DFAULT. MOST IMPORTANT ARE * C * * C * SRELPR MACHINE RELATIVE PRECISION * C * RPARM(1) STOPPING CRITERION * C * * C * ALSO CHANGE SYSTEM-DEPENDENT ROUTINE * C * CPTIME USED IN ITICK AND ITOCK * C * * C ************************************************** C C C SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IWKSP(1), IPARM(12), A NN, NW, IERR REAL A(1), RHS(NN), U(NN), WKSP(NW), RPARM(12) C C SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB1, IB2, IB3, IB4, IB5, IDGTS, IER, IERPER, ITIM1, ITIM2, A ITMAX1, JB3, JTIM1, JTIM2, LOOP, N, NB, NDUMMY, A NR, NRP1, N3 REAL DIGIT1, DIGIT2, TEMP, TIME1, TIME2, TOL C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C ... VARIABLES IN COMMON BLOCK - ITCOM1 C C IN - ITERATION NUMBER C IS - ITERATION NUMBER WHEN PARAMETERS LAST CHANGED C ISYM - SYMMETRIC/NONSYMMETRIC STORAGE FORMAT SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C LEVEL - LEVEL OF OUTPUT CONTROL SWITCH C NOUT - OUTPUT UNIT NUMBER C C ... VARIABLES IN COMMON BLOCK - ITCOM2 C C ADAPT - FULLY ADAPTIVE PROCEDURE SWITCH C BETADT - SWITCH FOR ADAPTIVE DETERMINATION OF BETA C CASEII - ADAPTIVE PROCEDURE CASE SWITCH C HALT - STOPPING TEST SWITCH C PARTAD - PARTIALLY ADAPTIVE PROCEDURE SWITCH C C ... VARIABLES IN COMMON BLOCK - ITCOM3 C C BDELNM - TWO NORM OF B TIMES DELTA-SUPER-N C BETAB - ESTIMATE FOR THE SPECTRAL RADIUS OF LU MATRIX C CME - ESTIMATE OF LARGEST EIGENVALUE C DELNNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION N C DELSNM - INNER PRODUCT OF PSEUDO-RESIDUAL AT ITERATION S C FF - ADAPTIVE PROCEDURE DAMPING FACTOR C GAMMA - ACCELERATION PARAMETER C OMEGA - OVERRELAXATION PARAMETER FOR SOR AND SSOR C QA - PSEUDO-RESIDUAL RATIO C QT - VIRTUAL SPECTRAL RADIUS C RHO - ACCELERATION PARAMETER C RRR - ADAPTIVE PARAMETER C SIGE - PARAMETER SIGMA-SUB-E C SME - ESTIMATE OF SMALLEST EIGENVALUE C SPECR - SPECTRAL RADIUS ESTIMATE FOR SSOR C SRELPR - MACHINE RELATIVE PRECISION C STPTST - STOPPING PARAMETER C UDNM - TWO NORM OF U C ZETA - STOPPING CRITERION C C C ... INITIALIZE COMMON BLOCKS C LEVEL = IPARM(2) NOUT = IPARM(4) IF (LEVEL .GE. 1) WRITE(NOUT,1) 1 FORMAT(1H0 ///1X,41HBEGINNING OF ITPACK SOLUTION MODULE RSSI ) IER = 0 IF(IPARM(1) .LE. 0) RETURN N = NN IF(IPARM(11) .EQ. 0) JTIM1 = ITICK(NDUMMY) IF (LEVEL .GE. 3) GO TO 2 CALL ECHOUT(IPARM,RPARM,7) GO TO 3 2 CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,1) 3 TEMP = 5.0E2*SRELPR IF (ZETA .GE. TEMP) GO TO 5 IF (LEVEL .GE. 1) WRITE (NOUT,4) ZETA,SRELPR,TEMP 4 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 26H IN ITPACK ROUTINE RSSI B / 1H , 14H RPARM(1) =,E10.3,7H (ZETA) C / 1H , 46H A VALUE THIS SMALL MAY HINDER CONVERGENCE D / 1H , 36H SINCE MACHINE PRECISION SRELPR = ,E10.3 E / 1H , 18H ZETA RESET TO ,E10.3) ZETA = TEMP 5 CONTINUE TIME1 = RPARM(9) TIME2 = RPARM(10) DIGIT1 = RPARM(11) DIGIT2 = RPARM(12) C C ... VERIFY N C IF (N.GT.0) GO TO 15 IER = 71 IF (LEVEL .GE. 0) WRITE(NOUT,14) N 14 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSSI B / 1H , 33H INVALID MATRIX DIMENSION, N =,I8) GO TO 160 15 CONTINUE C C ... REMOVE ROWS AND COLUMNS IF REQUESTED C IF(IPARM(10) .EQ. 0) GO TO 25 TOL = RPARM(8) CALL IVFILL(N,IWKSP,0) CALL VFILL(N,WKSP,0.0E0) CALL SBELM(N,IA,JA,A,RHS,IWKSP,WKSP,TOL,ISYM,LEVEL,NOUT,IER) IF(IER .EQ. 0) GO TO 25 IF (LEVEL .GE. 0) WRITE(NOUT,23) IER,TOL 23 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE SBELM C / 1H , 45H WHICH REMOVES ROWS AND COLUMNS OF SYSTEM D / 1H , 35H WHEN DIAGONAL ENTRY TOO LARGE E / 1H , 10H IER = ,I5,5X,12H RPARM(8) = ,E10.3,6H (TOL) ) C C ... INITIALIZE WKSP BASE ADDRESSES. 25 IB1 = 1 IB2 = IB1 + N JB3 = IB2 + N C C ... PERMUTE TO RED-BLACK SYSTEM IF POSSIBLE C NB = IPARM(9) IF(NB .GE. 0) GO TO 35 N3 = 3*N CALL IVFILL(N3,IWKSP,0) CALL PRBNDX(N,NB,IA,JA,IWKSP,IWKSP(IB2),LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 35 IF (LEVEL .GE. 0) WRITE(NOUT,30) IER,NB 30 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PRBNDX C / 1H , 41H WHICH COMPUTES THE RED-BLACK INDEXING D / 1H , 10H IER = ,I5,12H IPARM(9) = ,I5,5H (NB) ) GO TO 160 35 IF (NB .GE. 0 .AND. NB .LE. N) GO TO 43 IER = 74 IF (LEVEL .GE. 1) WRITE(NOUT,37) IER,NB 37 FORMAT(/10X,43HERROR DETECTED IN RED-BLACK SUBSYSTEM INDEX A /10X,5HIER =,I5,11H IPARM(9) =,I5,5H (NB) ) GO TO 160 43 IF (NB.NE.0 .AND. NB.NE.N) GO TO 45 NB = N/2 IF (LEVEL.GE.2 .AND. IPARM(9).GE.0) WRITE(NOUT,44) A IPARM(9),NB 44 FORMAT(/10X,12H IPARM(9) = ,I5,27H IMPLIES MATRIX IS DIAGONAL A /10X,13H NB RESET TO ,I5) C C ... PERMUTE MATRIX AND RHS C 45 IF(IPARM(9) .GE. 0) GO TO 52 IF (LEVEL .GE. 2) WRITE(NOUT,46) NB 46 FORMAT (/10X,27HORDER OF BLACK SUBSYSTEM = ,I5,5H (NB) ) CALL PERMAT (N,IA,JA,A,IWKSP,IWKSP(JB3),ISYM,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 51 IF (LEVEL .GE. 0) WRITE (NOUT,48) IER 48 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 40H WHICH DOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) GO TO 160 51 CALL PERVEC(N,RHS,IWKSP) CALL PERVEC(N,U,IWKSP) C C ... INITIALIZE WKSP BASE ADDRESSES C 52 NR = N - NB C NRP1 = NR + 1 IPARM(8) = N + NB IF (NW .GE. IPARM(8)) GO TO 55 IER = 72 IF (LEVEL .GE. 0) WRITE(NOUT,53) NW,IPARM(8) 53 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSSI B / 1H , 28H NOT ENOUGH WORKSPACE AT ,I10 C / 1H , 18H SET IPARM(8) =,I10,5H (NW) ) GO TO 160 C C ... SCALE LINEAR SYSTEM, U, AND RHS BY THE SQUARE ROOT OF THE C ... DIAGONAL ELEMENTS. C 55 CONTINUE CALL VFILL(IPARM(8),WKSP,0.0E0) CALL SCAL(N,IA,JA,A,RHS,U,WKSP,LEVEL,NOUT,IER) IF (IER .EQ. 0) GO TO 61 IF (LEVEL .GE. 0) WRITE(NOUT,60) IER 60 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE SCAL C / 1H , 30H WHICH SCALES THE SYSTEM D / 1H , 10H IER = ,I5) GO TO 160 61 IF (LEVEL .LE. 2) GO TO 65 WRITE(NOUT,62) 62 FORMAT(///1X,35HIN THE FOLLOWING, RHO AND GAMMA ARE A ,24H ACCELERATION PARAMETERS ) 65 IF (IPARM(11).NE.0)GO TO 76 ITIM1 = ITICK(NDUMMY) C C ... ITERATION SEQUENCE C 76 IF (N .GT. 1) GO TO 77 U(1) = RHS(1) GO TO 132 77 ITMAX1 = ITMAX + 1 DO 90 LOOP=1,ITMAX1 IN = LOOP - 1 IF (MOD(IN,2) .EQ. 1) GO TO 80 C C ... CODE FOR THE EVEN ITERATIONS. C C U = U(IN) C WKSP(IB1) = U(IN-1) C CALL ITRSSI(N,NB,IA,JA,A,RHS,U,WKSP(IB1),WKSP(IB2) ) C IF (HALT) GO TO 132 GO TO 90 C C ... CODE FOR THE ODD ITERATIONS. C C U = U(IN-1) C WKSP(IB1) = U(IN) C 80 CALL ITRSSI(N,NB,IA,JA,A,RHS,WKSP(IB1),U,WKSP(IB2) ) C IF (HALT) GO TO 132 90 CONTINUE C C ... ITMAX HAS BEEN REACHED C IF (IPARM(11) .NE. 0) GO TO 125 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 125 IF (LEVEL .GE. 1) WRITE(NOUT,130) ITMAX 130 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 26H IN ITPACK ROUTINE RSSI B / 1H , 26H FAILURE TO CONVERGE IN ,I5, 11H ITERATIONS ) IER = 73 IF (IPARM(3) .EQ. 0) RPARM(1) = STPTST GO TO 140 C C ... METHOD HAS CONVERGED C 132 IF (IPARM(11) .NE. 0) GO TO 134 ITIM2 = ITOCK(NDUMMY) TIME1 = AMAX0(0,ITIM2-ITIM1)*1.E-3 134 IF (LEVEL .GE. 1) WRITE(NOUT,136) IN 136 FORMAT(/1X,23HRSSI HAS CONVERGED IN ,I5,11H ITERATIONS ) C C ... PUT SOLUTION INTO U IF NOT ALREADY THERE. C 140 CONTINUE IF (N .EQ. 1) GO TO 142 IF (MOD(IN,2) .EQ. 1) CALL SCOPY(N,WKSP(IB1),1,U,1) CALL SCOPY(NR,RHS,1,U,1) CALL PRSRED(NB,NR,IA,JA,A,U(NRP1),U) C C ... UNSCALE THE MATRIX, SOLUTION, AND RHS VECTORS. C 142 CALL UNSCAL(N,IA,JA,A,RHS,U,WKSP) C C ... UN-PERMUTE MATRIX,RHS, AND SOLUTION C IF(IPARM(9) .GE. 0) GO TO 145 CALL PERMAT (N,IA,JA,A,IWKSP(IB2),IWKSP(JB3),ISYM, A LEVEL,NOUT,IERPER) IF (IERPER .EQ. 0) GO TO 144 IF (LEVEL .GE. 0) WRITE(NOUT,143) IERPER 143 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 36H CALLED FROM ITPACK ROUTINE RSSI B / 1H , 40H ERROR DETECTED IN SUBROUTINE PERMAT C / 1H , 45H WHICH UNDOES THE RED-BLACK PERMUTATION D / 1H , 10H IER = ,I5) IF(IER .EQ. 0) IER = IERPER GO TO 160 144 CALL PERVEC(N,RHS,IWKSP(IB2)) CALL PERVEC(N,U,IWKSP(IB2)) C C ... OPTIONAL ERROR ANALYSIS C 145 IDGTS = IPARM(12) IF(IDGTS .LT. 0) GO TO 150 IF(IPARM(2) .LE. 0) IDGTS = 0 CALL PERROR(N,IA,JA,A,RHS,U,WKSP,DIGIT1,DIGIT2,IDGTS) C C ... SET RETURN PARAMETERS IN IPARM AND RPARM C 150 IF(IPARM(11) .NE. 0) GO TO 155 JTIM2 = ITOCK(NDUMMY) TIME2 = AMAX0(0,JTIM2 - JTIM1)*1.E-3 155 IF (IPARM(3) .NE. 0) GO TO 160 IPARM(1) = IN IPARM(9) = NB RPARM(2) = CME RPARM(3) = SME RPARM(9) = TIME1 RPARM(10) = TIME2 RPARM(11) = DIGIT1 RPARM(12) = DIGIT2 C 160 CONTINUE IERR = IER IF (LEVEL .GE. 3) CALL ECHALL(N,IA,JA,A,RHS,IPARM,RPARM,2) C RETURN END SUBROUTINE ITJCG(NN,IA,JA,A,U,U1,D,D1,DTWD,TRI) ITJC0010 C C ... FUNCTION: C C THIS SUBROUTINE, ITJCG, PERFORMS ONE ITERATION OF THE C JACOBI CONJUGATE GRADIENT ALGORITHM. IT IS CALLED BY JCG. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. CONTAINS INFORMATION DEFINING C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. CONTAINS THE NONZERO VALUES OF THE C LINEAR SYSTEM. C U INPUT REAL VECTOR. CONTAINS THE VALUE OF THE C SOLUTION VECTOR AT THE END OF IN ITERATIONS. C U1 INPUT/OUTPUT REAL VECTOR. ON INPUT, IT CONTAINS C THE VALUE OF THE SOLUTION AT THE END OF THE IN-1 C ITERATION. ON OUTPUT, IT WILL CONTAIN THE NEWEST C ESTIMATE FOR THE SOLUTION VECTOR. C D INPUT REAL VECTOR. CONTAINS THE PSEUDO-RESIDUAL C VECTOR AFTER IN ITERATIONS. C D1 INPUT/OUTPUT REAL VECTOR. ON INPUT, D1 CONTAINS C THE PSEUDO-RESIDUAL VECTOR AFTER IN-1 ITERATIONS. ON C OUTPUT, IT WILL CONTAIN THE NEWEST PSEUDO-RESIDUAL C VECTOR. C DTWD REAL ARRAY. USED IN THE COMPUTATIONS OF THE C ACCELERATION PARAMETER GAMMA AND THE NEW PSEUDO- C RESIDUAL. C TRI REAL ARRAY. STORES THE TRIDIAGONAL MATRIX ASSOCIATED C WITH THE EIGENVALUES OF THE CONJUGATE GRADIENT C POLYNOMIAL. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), U(NN), U1(NN), D(NN), D1(NN), DTWD(NN), TRI(2,1) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER N REAL CON, C1, C2, C3, C4, DNRM, DTNRM, GAMOLD, RHOOLD, RHOTMP LOGICAL Q1 C C ... SPECIFICATIONS FOR FUNCTION SUBPROGRAMS C REAL SDOT C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN SUBROUTINE JCG C C ... COMPUTE NEW ESTIMATE FOR CME IF ADAPT = .TRUE. C IF (ADAPT) CALL CHGCON(TRI,GAMOLD,RHOOLD,1) C C ... TEST FOR STOPPING C N = NN DELNNM = SDOT(N,D,1,D,1) DNRM = DELNNM CON = CME CALL PSTOP(N,U,DNRM,CON,1,Q1) IF (HALT) GO TO 16 C C ... COMPUTE RHO AND GAMMA - ACCELERATION PARAMETERS C CALL VFILL(N,DTWD,0.E0) CALL PJAC(N,IA,JA,A,D,DTWD) DTNRM = SDOT(N,D,1,DTWD,1) IF(ISYM .EQ. 0) GO TO 12 RHOTMP = SDOT(N,DTWD,1,D1,1) CALL PARCON(DTNRM,C1,C2,C3,C4,GAMOLD,RHOTMP,1) RHOOLD = RHOTMP GO TO 14 12 CALL PARCON(DTNRM,C1,C2,C3,C4,GAMOLD,RHOOLD,1) C C ... COMPUTE U(IN+1) AND D(IN+1) C 14 CALL SUM3(N,C1,D,C2,U,C3,U1) CALL SUM3(N,C1,DTWD,C4,D,C3,D1) C C ... OUTPUT INTERMEDIATE INFORMATION C 16 CALL ITERM(N,A,U,DTWD,1) C C RETURN END SUBROUTINE ITJSI(NN,IA,JA,A,RHS,U,U1,D,ICNT) ITJS0010 C C ... FUNCTION: C C THIS SUBROUTINE, ITJSI, PERFORMS ONE ITERATION OF THE C JACOBI SEMI-ITERATIVE ALGORITHM. IT IS CALLED BY JSI. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT REAL VECTOR. CONTAINS THE ESTIMATE FOR THE C SOLUTION VECTOR AFTER IN ITERATIONS. C U1 INPUT/OUTPUT REAL VECTOR. ON INPUT, U1 CONTAINS THE C SOLUTION VECTOR AFTER IN-1 ITERATIONS. ON OUTPUT, C IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION C VECTOR. C D REAL ARRAY. D IS USED FOR THE COMPUTATION OF THE C PSEUDO-RESIDUAL ARRAY FOR THE CURRENT ITERATION. C ICNT NUMBER OF ITERATIONS SINCE LAST CHANGE OF SME C C ... SPECIFICATIONS OF ARGUMENTS C INTEGER IA(1), JA(1), A NN, ICNT REAL A(1), RHS(NN), U(NN), U1(NN), D(NN) C C ... SPECIFICATIONS OF LOCAL VARIABLES C INTEGER N REAL CON, C1, C2, C3, DNRM, DTNRM, OLDNRM LOGICAL Q1 C C ... SPECIFICATIONS OF FUNCTION SUBPROGRAMS C REAL SDOT LOGICAL TSTCHG, CHGSME C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN SUBROUTINE JSI C N = NN IF (IN .EQ. 0) ICNT = 0 C C ... COMPUTE PSEUDO-RESIDUALS C CALL SCOPY(N,RHS,1,D,1) CALL PJAC(N,IA,JA,A,U,D) CALL VEVMW(N,D,U) C C ... STOPPING AND ADAPTIVE CHANGE TESTS C OLDNRM = DELNNM DELNNM = SDOT(N,D,1,D,1) DNRM = DELNNM CON = CME CALL PSTOP(N,U,DNRM,CON,1,Q1) IF (HALT) GO TO 40 IF (.NOT.ADAPT) GO TO 30 IF (.NOT.TSTCHG(1)) GO TO 10 C C ... CHANGE ITERATIVE PARAMETERS (CME) C DTNRM = PVTBV(N,IA,JA,A,D) CALL CHGSI(DTNRM,1) IF (.NOT.ADAPT) GO TO 30 GO TO 20 C C ... TEST IF SME NEEDS TO BE CHANGED AND CHANGE IF NECESSARY. C 10 CONTINUE IF (CASEII) GO TO 30 IF (.NOT. CHGSME(OLDNRM,ICNT)) GO TO 30 ICNT = 0 C C ... COMPUTE U(IN+1) AFTER CHANGE OF PARAMETERS C 20 CALL SCOPY(N,U,1,U1,1) CALL SAXPY(N,GAMMA,D,1,U1,1) GO TO 40 C C ... COMPUTE U(IN+1) WITHOUT CHANGE OF PARAMETERS C 30 CALL PARSI(C1,C2,C3,1) CALL SUM3(N,C1,D,C2,U,C3,U1) C C ... OUTPUT INTERMEDIATE INFORMATION C 40 CALL ITERM(N,A,U,D,2) C RETURN END SUBROUTINE ITSOR (NN,IA,JA,A,RHS,U,WK) ITSO0010 C C ... FUNCTION: C C THIS SUBROUTINE, ITSOR, PERFORMS ONE ITERATION OF THE C SUCCESSIVE OVERRELAXATION ALGORITHM. IT IS CALLED BY SOR. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT/OUTPUT REAL VECTOR. ON INPUT, U CONTAINS THE C SOLUTION VECTOR AFTER IN ITERATIONS. ON OUTPUT, C IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION C VECTOR. C WK REAL ARRAY. WORK VECTOR OF LENGTH N. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), RHS(NN), U(NN), WK(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IP, IPHAT, IPSTAR, ISS, N REAL DNRM, H, OMEGAP, SPCRM1 LOGICAL CHANGE, Q1 C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN SUBROUTINE SOR C C ... SET INITIAL PARAMETERS NOT ALREADY SET C N = NN IF (IN .NE. 0) GO TO 10 CALL PSTOP(N,U,0.E0,0.E0,0,Q1) IF (ADAPT) GO TO 5 CHANGE = .FALSE. IP = 0 IPHAT = 2 ISS = 0 GO TO 20 C 5 CHANGE = .TRUE. IP = 0 OMEGAP = OMEGA OMEGA = 1.E0 ISS = 0 IPHAT = 2 IPSTAR = 4 IF (OMEGAP .LE. 1.E0) CHANGE = .FALSE. C C ... RESET OMEGA, IPHAT, AND IPSTAR (CIRCLE A IN FLOWCHART) C 10 IF (.NOT. CHANGE) GO TO 20 CHANGE = .FALSE. IS = IS + 1 IP = 0 ISS = 0 OMEGA = AMIN1 (OMEGAP,TAU(IS)) IPHAT = MAX0 ( 3 , IFIX( (OMEGA-1.E0)/(2.E0-OMEGA) ) ) IPSTAR = IPSTR (OMEGA) C C ... COMPUTE U (IN + 1) AND NORM OF DEL(S,P) - CIRCLE B IN FLOW CHART C 20 CONTINUE DELSNM = DELNNM SPCRM1 = SPECR CALL SCOPY(N,RHS,1,WK,1) CALL PFSOR1(N,IA,JA,A,U,WK) IF (DELNNM .EQ. 0.E0) GO TO 30 IF (IN .NE. 0) SPECR = DELNNM / DELSNM IF (IP .LT. IPHAT) GO TO 60 C C ... STOPPING TEST, SET H C IF (SPECR .GE. 1.E0) GO TO 60 IF (.NOT.(SPECR .GT. (OMEGA - 1.E0))) GO TO 30 H = SPECR GO TO 40 30 ISS = ISS + 1 H = OMEGA - 1.E0 C C ... PERFORM STOPPING TEST. C 40 CONTINUE DNRM = DELNNM ** 2 CALL PSTOP(N,U,DNRM,H,1,Q1) IF (HALT) GO TO 60 C C ... METHOD HAS NOT CONVERGED YET, TEST FOR CHANGING OMEGA C IF (.NOT. ADAPT) GO TO 60 IF (IP .LT. IPSTAR) GO TO 60 IF (OMEGA .GT. 1.E0) GO TO 50 CME = SQRT(ABS(SPECR)) OMEGAP = 2.E0 / (1.E0 + SQRT(ABS(1.E0 - SPECR))) CHANGE = .TRUE. GO TO 60 50 IF (ISS .NE. 0) GO TO 60 IF (SPECR .LE. (OMEGA - 1.E0)**FF) GO TO 60 IF ((SPECR + 5.E-5) .LE. SPCRM1) GO TO 60 C C ... CHANGE PARAMETERS C CME = (SPECR + OMEGA - 1.E0) / (SQRT(ABS(SPECR))*OMEGA) OMEGAP = 2.E0 / (1.E0 + SQRT(ABS(1.E0 - CME*CME))) CHANGE = .TRUE. C C ... OUTPUT INTERMEDIATE INFORMATION C 60 CALL ITERM(N,A,U,WK,3) IP = IP + 1 C C RETURN END SUBROUTINE ITSRCG(NN,IA,JA,A,RHS,U,U1,C,C1,D,DL,WK,TRI) ITSR0010 C C ... FUNCTION: C C THIS SUBROUTINE, ITSRCG, PERFORMS ONE ITERATION OF THE C SYMMETRIC SOR CONJUGATE GRADIENT ALGORITHM. IT IS CALLED BY C SSORCG. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT REAL VECTOR. CONTAINS THE ESTIMATE OF THE C SOLUTION VECTOR AFTER IN ITERATIONS. C U1 INPUT/OUTPUT REAL VECTOR. ON INPUT, U1 CONTAINS THE C THE ESTIMATE FOR THE SOLUTION AFTER IN-1 ITERATIONS. C ON OUTPUT, U1 CONTAINS THE UPDATED ESTIMATE. C C INPUT REAL VECTOR. CONTAINS THE FORWARD RESIDUAL C AFTER IN ITERATIONS. C C1 INPUT/OUTPUT REAL VECTOR. ON INPUT, C1 CONTAINS C THE FORWARD RESIDUAL AFTER IN-1 ITERATIONS. ON C OUTPUT, C1 CONTAINS THE UPDATED FORWARD RESIDUAL. C D REAL VECTOR. IS USED TO COMPUTE THE BACKWARD PSEUDO- C RESIDUAL VECTOR FOR THE CURRENT ITERATION. C DL REAL VECTOR. IS USED IN THE COMPUTATIONS OF THE C ACCELERATION PARAMETERS. C WK REAL VECTOR. WORKING SPACE OF LENGTH N. C TRI REAL VECTOR. STORES THE TRIDIAGONAL MATRIX ASSOCIATED C WITH THE CONJUGATE GRADIENT ACCELERATION. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), RHS(NN), U(NN), U1(NN), C(NN), C1(NN), D(NN), A DL(NN), WK(NN), TRI(2,1) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER N REAL BETNEW, CON, DNRM, GAMOLD, RHOOLD, RHOTMP, T1, A T2, T3, T4 LOGICAL Q1 C C ... SPECIFICATIONS FOR FUNCTION SUBPROGRAMS C REAL SDOT LOGICAL OMGCHG, OMGSTR C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN SUBROUTINE SSORCG C C ... CALCULATE S-PRIME FOR ADAPTIVE PROCEDURE. C N = NN IF (ADAPT.OR.PARTAD) CALL CHGCON(TRI,GAMOLD,RHOOLD,3) C C ... COMPUTE BACKWARD RESIDUAL C CALL SCOPY(N,RHS,1,WK,1) CALL SCOPY(N,C,1,D,1) CALL VEVPW(N,D,U) CALL PBSOR(N,IA,JA,A,D,WK) CALL VEVMW(N,D,U) C C ... COMPUTE ACCELERATION PARAMETERS AND THEN U(IN+1) (IN U1) C CALL SCOPY(N,D,1,DL,1) CALL VFILL(N,WK,0.E0) CALL PFSOR(N,IA,JA,A,DL,WK) CALL WEVMW(N,D,DL) DELNNM = SDOT(N,C,1,C,1) IF (DELNNM .EQ. 0.E0) GO TO 5 DNRM = SDOT(N,C,1,DL,1) IF(DNRM .EQ. 0.E0) GO TO 5 IF(ISYM .EQ. 0) GO TO 2 RHOTMP = SDOT(N,C,1,C1,1) - SDOT(N,DL,1,C1,1) CALL PARCON(DNRM,T1,T2,T3,T4,GAMOLD,RHOTMP,3) RHOOLD = RHOTMP GO TO 4 2 CALL PARCON(DNRM,T1,T2,T3,T4,GAMOLD,RHOOLD,3) 4 CALL SUM3(N,T1,D,T2,U,T3,U1) C C ... TEST FOR STOPPING C 5 BDELNM = SDOT(N,D,1,D,1) DNRM = BDELNM CON = SPECR CALL PSTOP(N,U,DNRM,CON,1,Q1) IF (HALT) GO TO 50 C C ... IF NON- OR PARTIALLY-ADAPTIVE, COMPUTE C(IN+1) AND EXIT. C IF (ADAPT) GO TO 10 CALL SUM3(N,-T1,DL,T2,C,T3,C1) GO TO 50 C C ... FULLY ADAPTIVE PROCEDURE C 10 CONTINUE IF (OMGSTR(1)) GO TO 40 IF (OMGCHG(1)) GO TO 20 C C ... PARAMETERS HAVE BEEN UNCHANGED. COMPUTE C(IN+1) AND EXIT. C CALL SUM3(N,-T1,DL,T2,C,T3,C1) GO TO 50 C C ... IT HAS BEEN DECIDED TO CHANGE PARAMETERS C (1) COMPUTE NEW BETAB IF BETADT = .TRUE. C 20 CONTINUE IF (.NOT.BETADT) GO TO 30 BETNEW = PBETA(N,IA,JA,A,D,WK,C1) / BDELNM BETAB = AMAX1(BETAB,.25E0,BETNEW) C C ... (2) COMPUTE NEW CME, OMEGA, AND SPECR C 30 CONTINUE IF(CASEII) GO TO 35 DNRM = PVTBV(N,IA,JA,A,D) GO TO 37 35 CALL VFILL(N,WK,0.E0) CALL PJAC(N,IA,JA,A,D,WK) DNRM = SDOT(N,WK,1,WK,1) 37 CALL OMEG(DNRM,3) C C ... (3) COMPUTE NEW FORWARD RESIDUAL SINCE OMEGA HAS BEEN CHANGED. C 40 CONTINUE CALL SCOPY(N,RHS,1,WK,1) CALL SCOPY(N,U1,1,C1,1) CALL PFSOR(N,IA,JA,A,C1,WK) CALL VEVMW(N,C1,U1) C C ... OUTPUT INTERMEDIATE RESULTS. C 50 CALL ITERM(N,A,U,WK,4) C RETURN END SUBROUTINE ITSRSI(NN,IA,JA,A,RHS,U,U1,C,D,CTWD,WK) ITSR0010 C ... FUNCTION: C C THIS SUBROUTINE, ITSRSI, PERFORMS ONE ITERATION OF THE C SYMMETRIC SOR SEMI-ITERATION ALGORITHM. IT IS CALLED BY C SSORSI. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. (= NN) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C U INPUT REAL VECTOR. CONTAINS THE ESTIMATE OF THE C SOLUTION VECTOR AFTER IN ITERATIONS. C U1 INPUT/OUTPUT REAL VECTOR. ON INPUT, U1 CONTAINS THE C THE ESTIMATE FOR THE SOLUTION AFTER IN-1 ITERATIONS. C ON OUTPUT, U1 CONTAINS THE UPDATED ESTIMATE. C C REAL VECTOR. IS USED TO COMPUTE THE FORWARD PSEUDO- C RESIDUAL VECTOR FOR THE CURRENT ITERATION. C D REAL VECTOR. IS USED TO COMPUTE THE BACKWARD PSEUDO- C RESIDUAL VECTOR FOR THE CURRENT ITERATION. C CTWD REAL VECTOR. IS USED IN THE COMPUTATIONS OF THE C ACCELERATION PARAMETERS. C WK REAL VECTOR. WORKING SPACE OF LENGTH N. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), RHS(NN), U(NN), U1(NN), C(NN), D(NN), CTWD(NN), A WK(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER N REAL BETNEW, CON, C1, C2, C3, DNRM LOGICAL Q1 C C ... SPECIFICATIONS FOR FUNCTION SUBPROGRAMS C REAL SDOT LOGICAL OMGSTR, TSTCHG C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN SUBROUTINE SSORSI C C ... COMPUTE PSEUDO-RESIDUALS (FORWARD AND BACKWARD) C N = NN CALL SCOPY(N,RHS,1,WK,1) CALL SCOPY(N,U,1,CTWD,1) CALL PSSOR1(N,IA,JA,A,CTWD,WK,C,D) C C ... COMPUTE U(IN+1) -- CONTAINED IN THE VECTOR U1. C CALL PARSI(C1,C2,C3,3) CALL SUM3(N,C1,D,C2,U,C3,U1) C C ... TEST FOR STOPPING C BDELNM = SDOT(N,D,1,D,1) DNRM = BDELNM CON = SPECR CALL PSTOP(N,U,DNRM,CON,1,Q1) IF (HALT .OR. .NOT.(ADAPT.OR.PARTAD)) GO TO 20 C C ... ADAPTIVE PROCEDURE C IF (OMGSTR(1)) GO TO 20 DELNNM = SDOT(N,C,1,C,1) IF (IN .EQ. IS) DELSNM = DELNNM IF (IN.EQ.0 .OR. .NOT.TSTCHG(1)) GO TO 20 C C ... IT HAS BEEN DECIDED TO CHANGE PARAMETERS. C ... (1) COMPUTE CTWD C CALL SCOPY(N,D,1,CTWD,1) CALL VFILL(N,WK,0.E0) CALL PFSOR(N,IA,JA,A,CTWD,WK) CALL VEVPW(N,CTWD,C) CALL VEVMW(N,CTWD,D) C C ... (2) COMPUTE NEW SPECTRAL RADIUS FOR CURRENT OMEGA. C DNRM = SDOT(N,C,1,CTWD,1) CALL CHGSI(DNRM,3) IF (.NOT. ADAPT) GO TO 20 C C ... (3) COMPUTE NEW BETAB IF BETADT = .TRUE. C IF (.NOT.BETADT) GO TO 10 BETNEW = PBETA(N,IA,JA,A,D,WK,CTWD) / BDELNM BETAB = AMAX1(BETAB, .25E0, BETNEW) C C ... (4) COMPUTE NEW CME, OMEGA, AND SPECR. C 10 CONTINUE IF(CASEII) GO TO 15 DNRM = PVTBV(N,IA,JA,A,D) GO TO 17 15 CALL VFILL(N,WK,0.E0) CALL PJAC(N,IA,JA,A,D,WK) DNRM = SDOT(N,WK,1,WK,1) 17 CALL OMEG(DNRM,3) C C ... OUTPUT INTERMEDIATE INFORMATION C 20 CALL ITERM(N,A,U,WK,5) C RETURN END SUBROUTINE ITRSCG(N,NNB,IA,JA,A,UB,UB1,DB,DB1,WB,TRI) ITRS0010 C C ... FUNCTION: C C THIS SUBROUTINE, ITRSCG, PERFORMS ONE ITERATION OF THE C REDUCED SYSTEM CONJUGATE GRADIENT ALGORITHM. IT IS C CALLED BY RSCG. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. C NB INPUT INTEGER. CONTAINS THE NUMBER OF BLACK POINTS C IN THE RED-BLACK MATRIX. (= NNB) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C UB INPUT REAL VECTOR. CONTAINS THE ESTIMATE FOR THE C SOLUTION ON THE BLACK POINTS AFTER IN ITERATIONS. C UB1 INPUT/OUTPUT REAL VECTOR. ON INPUT, UB1 CONTAINS THE C SOLUTION VECTOR AFTER IN-1 ITERATIONS. ON OUTPUT, C IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION C VECTOR. THIS IS ONLY FOR THE BLACK POINTS. C DB INPUT REAL ARRAY. DB CONTAINS THE VALUE OF THE C CURRENT PSEUDO-RESIDUAL ON THE BLACK POINTS. C DB1 INPUT/OUTPUT REAL ARRAY. DB1 CONTAINS THE PSEUDO- C RESIDUAL ON THE BLACK POINTS FOR THE IN-1 ITERATION C ON INPUT. ON OUTPUT, IT IS FOR THE IN+1 ITERATION. C WB REAL ARRAY. WB IS USED FOR COMPUTATIONS INVOLVING C BLACK VECTORS. C TRI REAL ARRAY. STORES THE TRIDIAGONAL MATRIX ASSOCIATED C WITH CONJUGATE GRADIENT ACCELERATION. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A N, NNB REAL A(1), UB(N), UB1(N), DB(NNB), DB1(N), WB(NNB), TRI(2,1) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER NB, NR, NRP1 REAL CON, C1, C2, C3, C4, DNRM, GAMOLD, RHOOLD, RHOTMP LOGICAL Q1 C C ... SPECIFICATIONS FOR FUNCTION SUBPROGRAMS C REAL SDOT C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN SUBROUTINE RSCG C C ... COMPUTE NEW ESTIMATE FOR CME IF ADAPT = .TRUE. C NB = NNB NR = N - NB NRP1 = NR + 1 IF (ADAPT) CALL CHGCON(TRI,GAMOLD,RHOOLD,2) C C ... TEST FOR STOPPING C DELNNM = SDOT(NB,DB,1,DB,1) DNRM = DELNNM CON = CME CALL PSTOP(NB,UB(NRP1),DNRM,CON,2,Q1) IF (HALT) GO TO 6 C C ... COMPUTE ACCELERATION PARAMETERS C CALL VFILL(NR,UB1,0.E0) CALL PRSRED(NB,NR,IA,JA,A,DB,UB1) CALL VFILL(NB,WB,0.E0) CALL PRSBLK(NB,NR,IA,JA,A,UB1,WB) DNRM = SDOT(NB,DB,1,WB,1) IF(ISYM .EQ. 0) GO TO 2 RHOTMP = SDOT(NB,WB,1,DB1,1) CALL PARCON(DNRM,C1,C2,C3,C4,GAMOLD,RHOTMP,2) RHOOLD = RHOTMP GO TO 4 2 CALL PARCON(DNRM,C1,C2,C3,C4,GAMOLD,RHOOLD,2) C C ... COMPUTE UB(IN+1) AND DB(IN+1) C 4 CALL SUM3(NB,C1,DB,C2,UB(NRP1),C3,UB1(NRP1)) CALL SUM3(NB,C1,WB,C4,DB,C3,DB1) C C ... OUTPUT INTERMEDIATE INFORMATION C 6 CALL ITERM(NB,A(NRP1), UB(NRP1),WB,6) C RETURN END SUBROUTINE ITRSSI(N,NNB,IA,JA,A,RHS,UB,UB1,DB) ITRS0010 C C ... FUNCTION: C C THIS SUBROUTINE, ITRSSI, PERFORMS ONE ITERATION OF THE C REDUCED SYSTEM SEMI-ITERATION ALGORITHM. IT IS C CALLED BY RSSI. C C ... PARAMETER LIST: C C N INPUT INTEGER. DIMENSION OF THE MATRIX. C NB INPUT INTEGER. CONTAINS THE NUMBER OF BLACK POINTS C IN THE RED-BLACK MATRIX. (= NNB) C IA,JA INPUT INTEGER VECTORS. THE TWO INTEGER ARRAYS OF C THE SPARSE MATRIX REPRESENTATION. C A INPUT REAL VECTOR. THE REAL ARRAY OF THE SPARSE C MATRIX REPRESENTATION. C RHS INPUT REAL VECTOR. CONTAINS THE RIGHT HAND SIDE C OF THE MATRIX PROBLEM. C UB INPUT REAL VECTOR. CONTAINS THE ESTIMATE FOR THE C SOLUTION ON THE BLACK POINTS AFTER IN ITERATIONS. C UB1 INPUT/OUTPUT REAL VECTOR. ON INPUT, UB1 CONTAINS THE C SOLUTION VECTOR AFTER IN-1 ITERATIONS. ON OUTPUT, C IT WILL CONTAIN THE NEWEST ESTIMATE FOR THE SOLUTION C VECTOR. THIS IS ONLY FOR THE BLACK POINTS. C DB INPUT REAL ARRAY. DB CONTAINS THE VALUE OF THE C CURRENT PSEUDO-RESIDUAL ON THE BLACK POINTS. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A N, NNB REAL A(1), RHS(N), UB(N), UB1(N), DB(NNB) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER NB, NR, NRP1 REAL CONST, C1, C2, C3, DNRM LOGICAL Q1 C C ... SPECIFICATIONS FOR FUNCTION SUBPROGRAMS C REAL SDOT LOGICAL TSTCHG C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN SUBROUTINE RSSI C C ... COMPUTE UR(IN) INTO UB C NB = NNB NR = N - NB NRP1 = NR + 1 CALL SCOPY(NR,RHS,1,UB,1) CALL PRSRED(NB,NR,IA,JA,A,UB(NRP1),UB) C C ... COMPUTE PSEUDO-RESIDUAL, DB(IN) C CALL SCOPY(NB,RHS(NRP1),1,DB,1) CALL PRSBLK(NB,NR,IA,JA,A,UB,DB) CALL VEVMW(NB,DB,UB(NRP1)) C C ... TEST FOR STOPPING C DELNNM = SDOT(NB,DB,1,DB,1) DNRM = DELNNM CONST = CME CALL PSTOP(NB,UB(NRP1),DNRM,CONST,2,Q1) IF (HALT) GO TO 20 IF (.NOT.ADAPT) GO TO 10 C C ... TEST TO CHANGE PARAMETERS C IF (.NOT. TSTCHG(2)) GO TO 10 C C ... CHANGE PARAMETERS C CALL VFILL(NR,UB1,0.E0) CALL PRSRED(NB,NR,IA,JA,A,DB,UB1) DNRM = SDOT(NR,UB1,1,UB1,1) CALL CHGSI(DNRM,2) IF (.NOT.ADAPT) GO TO 10 C C ... COMPUTE UB(N+1) AFTER CHANGING PARAMETERS C CALL SCOPY(NB,UB(NRP1),1,UB1(NRP1),1) CALL SAXPY(NB,GAMMA,DB,1,UB1(NRP1),1) GO TO 20 C C ... COMPUTE UB(N+1) WITHOUT CHANGE OF PARAMETERS C 10 CALL PARSI(C1,C2,C3,2) CALL SUM3(NB,C1,DB,C2,UB(NRP1),C3,UB1(NRP1)) C C ... OUTPUT INTERMEDIATE INFORMATION C 20 CALL ITERM(NB,A(NRP1), UB(NRP1),DB,7) C RETURN END INTEGER FUNCTION BISRCH ( N, K, L ) BISR0010 C C ... BISRCH IS AN INTEGER FUNCTION WHICH USES A BISECTION SEARCH C TO FIND THE ENTRY J IN THE ARRAY K SUCH THAT THE VALUE L IS C GREATER THAN OR EQUAL TO K(J) AND STRICTLY LESS THAN K(J+1). C C ... PARAMETER LIST: C C N INTEGER LENGTH OF VECTOR K C K INTEGER VECTOR C L INTEGER CONSTANT SUCH THAT K(J) .GE. L .LT. K(J+1) C WITH J RETURNED AS VALUE OF INTEGER FUNCTION BISRCH C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N, L, K(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER JLEFT, JMID, JRIGHT C JLEFT = 1 JRIGHT = N IF ( N .EQ. 2 ) GO TO 40 JMID = ( N + 1 ) / 2 C 10 IF ( L .GE. K(JMID) ) GO TO 20 C C ...... L .GE. K(LEFT) AND L .LT. K(JMID) C JRIGHT = JMID GO TO 30 C C ...... L .GE. K(JMID) AND L .LT. K(JRIGHT) C 20 JLEFT = JMID C C ...... TEST FOR CONVERGENCE C 30 IF ( JRIGHT - JLEFT .EQ. 1 ) GO TO 40 JMID = JLEFT + ( JRIGHT - JLEFT + 1 ) / 2 GO TO 10 C C ...... BISECTION SEARCH FINISHED C 40 BISRCH = JLEFT C RETURN END REAL FUNCTION CHEBY(QA,QT,RRR,IP,CME,SME) CHEB0010 C C COMPUTES THE SOLUTION TO THE CHEBYSHEV EQUATION C C ... PARAMETER LIST: C C QA RATIO OF PSEUDO-RESIDUALS C QT VIRTUAL SPECTRAL RADIUS C RRR ADAPTIVE PARAMETER C IP NUMBER OF ITERATIONS SINCE LAST CHANGE OF C PARAMETERS C CME, ESTIMATES FOR THE LARGEST AND SMALLEST EIGEN- C SME VALUES OF THE ITERATION MATRIX C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IP REAL CME, QA, QT, RRR, SME C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL X, Y, Z C Z = .5E0*(QA + SQRT(ABS(QA**2 - QT**2)))*(1.E0 + RRR**IP) X = Z **(1.E0/FLOAT(IP)) Y = (X + RRR/X)/(1.E0 + RRR) C CHEBY = .5E0*(CME + SME + Y * (2.E0 - CME - SME) ) C RETURN END SUBROUTINE CHGCON(TRI,GAMOLD,RHOOLD,IBMTH) CHGC0010 C C COMPUTES THE NEW ESTIMATE FOR THE LARGEST EIGENVALUE FOR C CONJUGATE GRADIENT ACCELERATION. C C ... PARAMETER LIST: C C TRI TRIDIAGONAL MATRIX ASSOCIATED WITH THE EIGENVALUES C OF THE CONJUGATE GRADIENT POLYNOMIAL C GAMOLD C AND C RHOOLD PREVIOUS VALUES OF ACCELERATION PARAMETERS C IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY CG C IBMTH = 1, JACOBI C = 2, REDUCED SYSTEM C = 3, SSOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IBMTH REAL TRI(2,1), A GAMOLD, RHOOLD C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IB2, IB3, IER, IP REAL CMOLD, END, START C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C GO TO (10,20,30),IBMTH C C ... JACOBI CONJUGATE GRADIENT C 10 START = CME IP = IN GO TO 40 C C ... REDUCED SYSTEM CG C 20 START = CME ** 2 IP = IN GO TO 40 C C ... SSOR CG C 30 IF (ADAPT) START = SPR IF (.NOT.ADAPT) START = SPECR IP = IN - IS C C ... DEFINE THE MATRIX C 40 IF (IP.GE.2) GO TO 60 IF (IP.EQ.1) GO TO 50 C C ... IP = 0 C END = 0.E0 CMOLD = 0.E0 GO TO 80 C C ... IP = 1 C 50 END = 1.E0 - 1.E0/GAMMA TRI(1,1) = END TRI(2,1) = 0.E0 GO TO 80 C C ... IP > 1 C 60 IF (ABS(START-CMOLD) .LE. ZETA*START) GO TO 90 CMOLD = START C C ... COMPUTE THE LARGEST EIGENVALUE C TRI(1,IP) = 1.E0 - 1.E0/GAMMA TRI(2,IP)=(RHO-1.E0)/(RHO*RHOOLD*GAMMA*GAMOLD) IF(ISYM .NE. 0) GO TO 72 END = EIGVSS(IP,TRI,START,ZETA,ITMAX,IER) IF (IER .EQ. 0) GO TO 75 IF (LEVEL .GE. 2) WRITE (NOUT,71) IER 71 FORMAT(/10X,47HDIFFICULTY IN COMPUTATION OF MAXIMUM EIGENVALUE A /15X,19HOF ITERATION MATRIX B /10X,32HSUBROUTINE ZBRENT RETURNED IER = ,I5) GO TO 75 72 IB2 = 1 + IP IB3 = IB2 + IP/2 + 1 END=EIGVNS(IP,TRI,TRI(1,IB2),TRI(1,IB3),IER) IF (IER .EQ. 0) GO TO 75 IF (LEVEL .GE. 2) WRITE (NOUT,73) IER 73 FORMAT(/10X,47HDIFFICULTY IN COMPUTATION OF MAXIMUM EIGENVALUE A /15X,19HOF ITERATION MATRIX B /10X,32HSUBROUTINE EQRT1S RETURNED IER = ,I5) 75 CONTINUE IF (IER.NE.0) GO TO 100 C C ... SET SPECTRAL RADIUS FOR THE VARIOUS METHODS C 80 IF (IBMTH .EQ. 1) CME = END IF (IBMTH .EQ. 2) CME = SQRT(ABS(END)) IF (IBMTH .EQ. 3 .AND. ADAPT) SPR = END IF (IBMTH .EQ. 3 .AND. .NOT.ADAPT) SPECR = END RETURN C C ... RELATIVE CHANGE IN CME IS LESS THAN ZETA. THEREFORE STOP C CHANGING. C 90 ADAPT = .FALSE. PARTAD = .FALSE. RETURN C C ... ESTIMATE FOR CME > 1.E0. THEREFORE NEED TO STOP ADAPTIVE C PROCEDURE AND KEEP OLD VALUE OF CME. C 100 ADAPT = .FALSE. PARTAD = .FALSE. IF (LEVEL.GE.2) WRITE(NOUT,110) IN,START 110 FORMAT(/10X,43HESTIMATE OF MAXIMUM EIGENVALUE OF JACOBI A /15X,25HMATRIX (CME) NOT ACCURATE B /10X,43HADAPTIVE PROCEDURE TURNED OFF AT ITERATION ,I5 C /10X,38HFINAL ESTIMATE OF MAXIMUM EIGENVALUE =,E15.7/) C RETURN END SUBROUTINE CHGSI(DTNRM,IBMTH) CHGS0010 C C ... COMPUTES NEW CHEBYSHEV ACCELERATION PARAMETERS ADAPTIVELY. C C ... PARAMETER LIST: C C DTNRM NUMERATOR OF RAYLEIGH QUOTIENT C IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY SI C IBMTH = 1, JACOBI C = 2, REDUCED SYSTEM C = 3, SYMMETRIC SOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IBMTH REAL DTNRM C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL CMOLD, ZM1, ZM2 C C ... SPECIFICATIONS FOR FUNCTION SUBPROGRAMS C REAL CHEBY C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C C GO TO (10,110,210), IBMTH C C --------------------- C ... JACOBI SEMI-ITERATIVE C --------------------- C C ... CHEBYSHEV EQUATION C 10 CONTINUE IF (IN .EQ. 0) ZM1 = CME IF (IN .NE. 0) ZM1 = CHEBY(QA,QT,RRR,IN-IS,CME,SME) C C ... RAYLEIGH QUOTIENT C ZM2 = DTNRM / DELNNM C C ... COMPUTATION OF ITERATIVE PARAMETERS C CMOLD = CME CME = AMAX1 (ZM1,ZM2,CMOLD) IF (CME .GE. 1.E0) GO TO 60 IF (CASEII) SME = -CME SIGE = (CME - SME) / (2.E0 - CME - SME) GAMMA = 2.E0 / (2.E0 - CME - SME) RRR = (1.E0 - SQRT(ABS(1.E0 - SIGE*SIGE)))/ A (1.E0 + SQRT(ABS(1.E0-SIGE*SIGE))) IS = IN DELSNM = DELNNM RHO = 1.E0 IF (LEVEL .GE. 2) WRITE(NOUT,1000) IN,ZM1,ZM2,CME,GAMMA,CME RETURN C C ... ADAPTIVE PROCEDURE FAILED FOR JACOBI SI C 60 CME = CMOLD ADAPT = .FALSE. IF (LEVEL .GE. 2) WRITE(NOUT,1010) IN,CME RETURN C C C ----------------------------- C ... REDUCED SYSTEM SEMI-ITERATIVE C ----------------------------- C C C ... CHEBYSHEV EQUATION C 110 CONTINUE IF (IN .EQ. 0) ZM1 = CME IF (IN .NE. 0) ZM1 = CHEBY(QA,QT,RRR,2*(IN-IS),0.E0,0.E0) C C ... RAYLEIGH QUOTIENT C ZM2 = SQRT( ABS(DTNRM / DELNNM) ) C C ... COMPUTATION OF NEW ITERATIVE PARAMETERS C CMOLD = CME CME = AMAX1(ZM1,ZM2,CMOLD) IF (CME .GE. 1.E0) GO TO 140 SIGE = CME*CME / (2.E0 - CME*CME) GAMMA = 2.E0 / (2.E0 - CME*CME) RRR = (1.E0 - SQRT(ABS(1.E0 - CME*CME)))/ A (1.E0 + SQRT(ABS(1.E0-CME*CME))) IS = IN DELSNM = DELNNM RHO = 1.E0 IF (LEVEL .GE. 2) WRITE(NOUT,1000) IN,ZM1,ZM2,CME,GAMMA,CME RETURN C C ... ADAPTIVE PROCEDURE FAILED FOR REDUCED SYSTEM SI C 140 CME = CMOLD ADAPT = .FALSE. IF (LEVEL .GE. 2) WRITE(NOUT,1010) IN,CME RETURN C C C ----------------------------- C ... SYMMETRIC SOR SEMI-ITERATIVE C ---------------------------- C C 210 CONTINUE IF (SPECR .EQ. 0.E0) SPECR = .171572875E0 IF (IN.EQ.0) GO TO 220 ZM1 = CHEBY (QA,QT,RRR,IN-IS,SPECR,0.E0) GO TO 230 220 ZM1 = SPECR SPR = SPECR C C ... RAYLEIGH QUOTIENT C 230 ZM2 = DTNRM / DELNNM C C ... COMPUTATION OF NEW ESTIMATE FOR SPECTRAL RADIUS C IF (ADAPT) GO TO 240 C C ... PARTIALLY ADAPTIVE SSOR SI C SPECR = AMAX1 (ZM1,ZM2,SPECR) IS = IN DELSNM = DELNNM IF (LEVEL .GE. 2) WRITE(NOUT,1005) IN,ZM1,ZM2,CME,SPECR RETURN C C ... FULLY ADAPTIVE SSOR SI C 240 SPR = AMAX1 (ZM1,ZM2,SPR) RETURN C C ... FORMAT STATEMENTS C 1000 FORMAT(/30X,40HPARAMETERS WERE CHANGED AT ITERATION NO. ,I5 A /35X,34HSOLUTION TO CHEBYSHEV EQN. = ,E15.7 B /35X,34HSOLUTION TO RAYLEIGH QUOTIENT = ,E15.7 C /35X,34HNEW ESTIMATE FOR CME = ,E15.7 D /35X,34HNEW ESTIMATE FOR GAMMA = ,E15.7 E /35X,34HNEW ESTIMATE FOR SPECTRAL RADIUS = ,E15.7 /) C 1005 FORMAT(/30X,40HPARAMETERS WERE CHANGED AT ITERATION NO. ,I5 A /35X,34HSOLUTION TO CHEBYSHEV EQN. = ,E15.7 B /35X,34HSOLUTION TO RAYLEIGH QUOTIENT = ,E15.7 C /35X,34HNEW ESTIMATE FOR CME = ,E15.7 D /35X,34HNEW ESTIMATE FOR SPECTRAL RADIUS = ,E15.7 /) C 1010 FORMAT(/10X,43HESTIMATE OF MAXIMUM EIGENVALUE OF JACOBI A /15X,22HMATRIX (CME) TOO LARGE B /10X,43HADAPTIVE PROCEDURE TURNED OFF AT ITERATION ,I5 C /10X,38HFINAL ESTIMATE OF MAXIMUM EIGENVALUE =,E15.7/) C END LOGICAL FUNCTION CHGSME (OLDNRM,ICNT) CHGS0010 C C ... THIS FUNCTION TESTS FOR JACOBI SI WHETHER SME SHOULD BE CHANGED C ... WHEN CASEII = .FALSE.. IF THE TEST IS POSITIVE THE NEW VALUE C ... OF SME IS COMPUTED. C C ... PARAMETER LIST: C C OLDNRM SQUARE OF THE NORM OF THE PSEUDO-RESIDUAL C AT THE LAST ITERATION C ICNT NUMBER OF ITERATIONS SINCE LAST CHANGE OF C PARAMETERS C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER ICNT REAL OLDNRM C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IP REAL Q, RN, SM1, SM2, WP, Z C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE CHGSME = .FALSE. RN = SQRT(DELNNM/OLDNRM) IF (.NOT. (QA.GT.1.E0 .AND. RN.GT.1.E0)) RETURN IF (IN .LE. IS+2) RETURN C ICNT = ICNT + 1 IF (ICNT .LT. 3) RETURN C C ... CHANGE SME IN J-SI ADAPTIVE PROCEDURE C CHGSME = .TRUE. SM1 = 0.E0 SM2 = 0.E0 IF (SME.GE.CME) GO TO 10 C C ... COMPUTE SM1 C IP = IN - IS Q = QA * (1.E0 + RRR**IP)/(2.E0*SQRT(RRR**IP)) Z = (Q + SQRT(Q**2 - 1.E0))**(1.E0/FLOAT(IP)) WP = (Z**2 + 1.E0)/(2.E0*Z) SM1 = .5E0*(CME + SME - WP*(CME - SME)) C C ... COMPUTE SM2 C Q = RN*(1.E0 + RRR**IP)/((1.E0 + RRR**(IP-1))*SQRT(RRR)) WP = (Q**2 + 1.E0)/(2.E0*Q) SM2 = .5E0*(CME + SME - WP*(CME - SME)) C 10 SME = AMIN1(1.25E0*SM1,1.25E0*SM2,SME,-1.E0) SIGE = (CME - SME)/(2.E0 - CME - SME) GAMMA = 2.E0 / (2.E0 - CME - SME) RRR = (1.E0 - SQRT(1.E0-SIGE**2)) / (1.E0 + SQRT(1.E0-SIGE**2)) IS = IN DELSNM = DELNNM RHO = 1.E0 C IF (LEVEL .GE. 2) WRITE(NOUT,20) IN,SM1,SM2,SME C 20 FORMAT(/30X,41HESTIMATE OF SMALLEST EIGENVALUE OF JACOBI A /37X,34HMATRIX (SME) CHANGED AT ITERATION ,I5 B /35X,34HFIRST ESTIMATE OF SME =,E15.7 C /35X,34HSECOND ESTIMATE OF SME =,E15.7 D /35X,34HNEW ESTIMATE OF SME =,E15.7 /) C RETURN END REAL FUNCTION DETERM(N,TRI,XLMDA) DETE0010 C C THIS SUBROUTINE COMPUTES THE DETERMINANT OF A SYMMETRIC C TRIDIAGONAL MATRIX GIVEN BY TRI. DET(TRI - XLMDA*I) = 0 C C ... PARAMETER LIST C C N ORDER OF TRIDIAGONAL SYSTEM C TRI SYMMETRIC TRIDIAGONAL MATRIX OF ORDER N C XLMDA ARGUMENT FOR CHARACTERISTIC EQUATION C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N REAL TRI(2,1), A XLMDA C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER ICNT, L, NM1 REAL D1, D2, D3 C NM1 = N - 1 D2 = TRI(1,N) - XLMDA D1 = D2 * (TRI(1,NM1) - XLMDA) - TRI(2,N) IF (N.EQ.2) GO TO 20 C C ... BEGINNING OF LOOP C DO 10 ICNT=2,NM1 L = NM1 - ICNT + 2 D3 = D2 D2 = D1 D1 = (TRI(1,L-1) - XLMDA) * D2 - D3 * TRI(2,L) 10 CONTINUE C C ... DETERMINANT COMPUTED C 20 DETERM = D1 C RETURN END SUBROUTINE ECHALL(NN,IA,JA,A,RHS,IPARM,RPARM,ICALL) ECHA0010 C C ... THIS ROUTINE INITIALIZES THE ITPACK COMMON BLOCKS FROM THE C ... INFORMATION CONTAINED IN IPARM AND RPARM. ECHALL ALSO PRINTS THE C ... VALUES OF ALL THE PARAMETERS IN IPARM AND RPARM. C C ... PARAMETER LIST: C C IPARM C AND C RPARM ARRAYS OF PARAMETERS SPECIFYING OPTIONS AND C TOLERANCES C ICALL INDICATOR OF WHICH PARAMETERS ARE BEING PRINTED C ICALL = 1, INITIAL PARAMETERS C ICALL = 2, FINAL PARAMETERS C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), IPARM(12), A NN, ICALL REAL A(1), RHS(NN), RPARM(12) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, N, NP1, NZRO C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C IF (ICALL .NE. 1) GO TO 20 N = NN NP1 = N + 1 NZRO = IA(NP1) - 1 C C ... INITIALIZE ITPACK COMMON C ZETA = RPARM(1) CME = RPARM(2) SME = RPARM(3) FF = RPARM(4) OMEGA = RPARM(5) SPECR = RPARM(6) BETAB = RPARM(7) ITMAX = IPARM(1) LEVEL = IPARM(2) ISYM = IPARM(5) C ADAPT = .FALSE. PARTAD = .FALSE. BETADT = .FALSE. IF (IPARM(6) .EQ. 1 .OR. IPARM(6) .EQ. 3) ADAPT = .TRUE. IF (IPARM(6) .EQ. 1) BETADT = .TRUE. IF (IPARM(6) .EQ. 2) PARTAD = .TRUE. C CASEII = .FALSE. IF (IPARM(7) .EQ. 2) CASEII = .TRUE. IF (CASEII) SME = -CME IF (.NOT.CASEII .AND. SME .EQ. 0.E0) SME = -1.E0 SPR = SME C C ... SET REST OF COMMON VARIABLES TO ZERO C IN = 0 IS = 0 HALT = .FALSE. BDELNM = 0.E0 DELNNM = 0.E0 DELSNM = 0.E0 GAMMA = 0.E0 QA = 0.E0 QT = 0.E0 RHO = 0.E0 RRR = 0.E0 SIGE = 0.E0 STPTST = 0.E0 UDNM = 0.E0 C IF (LEVEL .LE. 4) GO TO 10 C C THIS SECTION OF ECHALL CAUSES PRINTING OF THE LINEAR SYSTEM AND C THE ITERATIVE PARAMETERS C WRITE (NOUT,1) 1 FORMAT (///30X,31HTHE LINEAR SYSTEM IS AS FOLLOWS ) WRITE (NOUT,2) 2 FORMAT (/2X,8HIA ARRAY ) WRITE (NOUT,3) (IA(I),I=1,NP1) 3 FORMAT (2X,10(2X,I8)) WRITE (NOUT,4) 4 FORMAT (/2X,8HJA ARRAY ) WRITE (NOUT,3) (JA(I),I=1,NZRO) WRITE (NOUT,5) 5 FORMAT (/2X,8H A ARRAY ) WRITE (NOUT,6) (A(I),I=1,NZRO) 6 FORMAT (2X,5(2X,G20.13)) WRITE (NOUT,7) 7 FORMAT (/2X,9HRHS ARRAY ) WRITE (NOUT,6) (RHS(I),I=1,N) 10 WRITE (NOUT,15) 15 FORMAT (///30X,28HINITIAL ITERATIVE PARAMETERS ) GO TO 40 20 WRITE (NOUT,30) 30 FORMAT (///30X,26HFINAL ITERATIVE PARAMETERS ) 40 WRITE (NOUT,50) IPARM(1),LEVEL,IPARM(3),NOUT,ISYM,IPARM(6) 50 FORMAT (35X,11HIPARM(1) =,I15,4X,7H(ITMAX) A /35X,11HIPARM(2) =,I15,4X,8H(LEVEL) B /35X,11HIPARM(3) =,I15,4X,8H(IRESET) C /35X,11HIPARM(4) =,I15,4X,8H(NOUT) D /35X,11HIPARM(5) =,I15,4X,8H(ISYM) E /35X,11HIPARM(6) =,I15,4X,8H(IADAPT) ) WRITE (NOUT,60) IPARM(7),IPARM(8),IPARM(9),IPARM(10), A IPARM(11),IPARM(12) 60 FORMAT (35X,11HIPARM(7) =,I15,4X,7H(ICASE) A /35X,11HIPARM(8) =,I15,4X,7H(NWKSP) B /35X,11HIPARM(9) =,I15,4X,8H(NB) C /35X,11HIPARM(10) =,I15,4X,9H(IREMOVE) D /35X,11HIPARM(11) =,I15,4X,7H(ITIME) E /35X,11HIPARM(12) =,I15,4X,7H(IDGTS) ) WRITE (NOUT,70) ZETA,CME,SME,FF,OMEGA,SPECR 70 FORMAT (35X,11HRPARM(1) =,E15.8,4X,8H(ZETA) A /35X,11HRPARM(2) =,E15.8,4X,8H(CME) B /35X,11HRPARM(3) =,E15.8,4X,8H(SME) C /35X,11HRPARM(4) =,E15.8,4X,8H(FF) D /35X,11HRPARM(5) =,E15.8,4X,8H(OMEGA) E /35X,11HRPARM(6) =,E15.8,4X,8H(SPECR) ) WRITE (NOUT,80) BETAB,RPARM(8),RPARM(9),RPARM(10),RPARM(11), A RPARM(12) 80 FORMAT (35X,11HRPARM(7) =,E15.8,4X,8H(BETAB) A /35X,11HRPARM(8) =,E15.8,4X,5H(TOL) B /35X,11HRPARM(9) =,E15.8,4X,7H(TIME1) C /35X,11HRPARM(10) =,E15.8,4X,7H(TIME2) D /35X,11HRPARM(11) =,E15.8,4X,8H(DIGIT1) E /35X,11HRPARM(12) =,E15.8,4X,8H(DIGIT2) ) C RETURN END SUBROUTINE ECHOUT(IPARM,RPARM,IMTHD) ECHO0010 C C THIS ROUTINE INITIALIZES THE ITPACK COMMON BLOCKS FROM THE C INFORMATION CONTAINED IN IPARM AND RPARM. C C ... PARAMETER LIST: C C IPARM C AND C RPARM ARRAYS OF PARAMETERS SPECIFYING OPTIONS AND C TOLERANCES C IMTHD INDICATOR OF METHOD C IMTHD = 1, JCG C IMTHD = 2, JSI C IMTHD = 3, SOR C IMTHD = 4, SSORCG C IMTHD = 5, SSORSI C IMTHD = 6, RSCG C IMTHD = 7, RSSI C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IPARM(12), A IMTHD REAL RPARM(12) C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C C ... INITIALIZE ITPACK COMMON C ZETA = RPARM(1) CME = RPARM(2) SME = RPARM(3) FF = RPARM(4) OMEGA = RPARM(5) SPECR = RPARM(6) BETAB = RPARM(7) ITMAX = IPARM(1) LEVEL = IPARM(2) ISYM = IPARM(5) C ADAPT = .FALSE. PARTAD = .FALSE. BETADT = .FALSE. IF (IPARM(6) .EQ. 1 .OR. IPARM(6) .EQ. 3) ADAPT = .TRUE. IF (IPARM(6) .EQ. 1) BETADT = .TRUE. IF (IPARM(6) .EQ. 2) PARTAD = .TRUE. C CASEII = .FALSE. IF (IPARM(7) .EQ. 2) CASEII = .TRUE. IF (CASEII) SME = -CME IF (.NOT.CASEII .AND. SME .EQ. 0.E0) SME = -1.E0 SPR = SME C C ... SET REST OF COMMON VARIABLES TO ZERO C IN = 0 IS = 0 HALT = .FALSE. BDELNM = 0.E0 DELNNM = 0.E0 DELSNM = 0.E0 GAMMA = 0.E0 QA = 0.E0 QT = 0.E0 RHO = 0.E0 RRR = 0.E0 SIGE = 0.E0 STPTST = 0.E0 UDNM = 0.E0 IF (LEVEL .LE. 2) RETURN C C ... THIS SECTION OF ECHOUT ECHOES THE INPUT VALUES FOR THE INITIAL C ITERATIVE PARAMETERS C WRITE(NOUT, 20) ISYM, ITMAX, ZETA, ADAPT, CASEII 20 FORMAT(///30X,28HINITIAL ITERATIVE PARAMETERS,3X, A 17HRELEVANT SWITCHES B /35X,8HISYM =,I15,8X,8HIPARM(5) C /35X,8HITMAX =,I15,8X,8HIPARM(1) D /35X,8HZETA =,E15.8,8X,8HRPARM(1) E /35X,8HADAPT =,L15,8X,8HIPARM(6) F /35X,8HCASEII =,L15,8X,8HIPARM(7)) GO TO (90,30,101,80,60,90,30), IMTHD C C ... JSI, RSSI C 30 WRITE(NOUT,50) FF,CME ,SME 50 FORMAT( 35X,8HFF =,E15.8,8X,8HRPARM(4) A /35X,8HCME =,E15.8,8X,8HRPARM(2) B /35X,8HSME =,E15.8,8X,8HRPARM(3)///) RETURN C C ... SSORSI C 60 WRITE(NOUT,70) PARTAD,FF,CME,OMEGA,SPECR,BETAB,BETADT 70 FORMAT( 35X,8HPARTAD =,L15,8X,8HIPARM(6) A /35X,8HFF =,E15.8,8X,8HRPARM(4) B /35X,8HCME =,E15.8,8X,8HRPARM(2) C /35X,8HOMEGA =,E15.8,8X,8HRPARM(5) D /35X,8HSPECR =,E15.8,8X,8HRPARM(6) E /35X,8HBETAB =,E15.8,8X,8HRPARM(7) F /35X,8HBETADT =,L15,8X,8HIPARM(6)///) RETURN C C ... SSORCG C 80 WRITE(NOUT,85) PARTAD,CME,OMEGA,SPECR,BETAB,BETADT 85 FORMAT( 35X,8HPARTAD =,L15,8X,8HIPARM(6) B /35X,8HCME =,E15.8,8X,8HRPARM(2) C /35X,8HOMEGA =,E15.8,8X,8HRPARM(5) D /35X,8HSPECR =,E15.8,8X,8HRPARM(6) E /35X,8HBETAB =,E15.8,8X,8HRPARM(7) F /35X,8HBETADT =,L15,8X,8HIPARM(6)///) RETURN C C ... JCG, RSCG C 90 IF (ADAPT) RETURN WRITE(NOUT,100) CME 100 FORMAT( 35X,8HCME =,E15.8,8X,8HRPARM(2)///) C 101 CONTINUE RETURN END REAL FUNCTION EIGVNS(N,TRI,D,E2,IER) EIGV0010 C C COMPUTES THE LARGEST EIGENVALUE OF A SYMMETRIC TRIDIAGONAL MATRIX C FOR CONJUGATE GRADIENT ACCELERATION. C C ... PARAMETER LIST: C C N ORDER OF TRIDIAGONAL SYSTEM C TRI SYMMETRIC TRIDIAGONAL MATRIX OF ORDER N C D ARRAY FOR EQRT1S (NEGATIVE DIAGONAL ELEMENTS) C E2 ARRAY FOR EQRT1S (SUPER DIAGONAL ELEMENTS) C IER ERROR FLAG: ON RETURN, IER=0 INDICATES THAT C THE LARGEST EIGENVALUE OF TRI WAS FOUND. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N, IER REAL TRI(2,1), D(N), E2(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I C EIGVNS = 0.E0 C D(1)=-TRI(1,1) DO 10 I=2,N D(I)=-TRI(1,I) 10 E2(I)=ABS(TRI(2,I)) C CALL EQRT1S(D,E2,N,1,0,IER) EIGVNS = -D(1) C RETURN END REAL FUNCTION EIGVSS(N,TRI,START,ZETA,ITMAX,IER) EIGV0010 C C COMPUTES THE LARGEST EIGENVALUE OF A SYMMETRIC TRIDIAGONAL MATRIX C FOR CONJUGATE GRADIENT ACCELERATION. C MODIFIED IMSL ROUTINE ZBRENT USED. C C ... PARAMETER LIST: C C N ORDER OF TRIDIAGONAL SYSTEM C TRI SYMMETRIC TRIDIAGONAL MATRIX OF ORDER N C START INITIAL LOWER BOUND OF INTERVAL CONTAINING ROOT C ZETA STOPPING CRITERIA C IER ERROR FLAG: ON RETURN, IER=0 INDICATES THAT C THE LARGEST EIGENVALUE OF TRI WAS FOUND. C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N, ITMAX, IER REAL TRI(2,1), A START, ZETA C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER MAXFN, NSIG, ITMP C EIGVSS = 0.E0 ITMP = IFIX(-ALOG10(ABS(ZETA))) NSIG = MAX0(ITMP,4) MAXFN = MAX0(ITMAX,50) EPS = AMIN1(ZETA,0.5E-4) A = START B = 1.0E0 CALL ZBRENT(N,TRI,EPS,NSIG,A,B,MAXFN,IER) EIGVSS = B C RETURN END SUBROUTINE EQRT1S (D,E2,NN,M,ISW,IERR) EQRT0010 C MODIFIED IMSL ROUTINE NAME - EQRT1S C C----------------------------------------------------------------------- C C COMPUTER - CDC/SINGLE C C LATEST REVISION - JUNE 1, 1980 C C PURPOSE - SMALLEST OR LARGEST M EIGENVALUES OF A C SYMMETRIC TRIDIAGONAL MATRIX C C USAGE - CALL EQRT1S (D,E2,N,M,ISW,IER) C C ARGUMENTS D - INPUT VECTOR OF LENGTH N CONTAINING C THE DIAGONAL ELEMENTS OF THE MATRIX. THE C COMPUTED EIGENVALUES REPLACE THE FIRST M C COMPONENTS OF THE VECTOR D IN NON- C DECREASING SEQUENCE, WHILE THE REMAINING C COMPONENTS ARE LOST. C E2 - INPUT VECTOR OF LENGTH N CONTAINING C THE SQUARES OF THE OFF-DIAGONAL ELEMENTS C OF THE MATRIX. INPUT E2 IS DESTROYED. C N - INPUT SCALAR CONTAINING THE ORDER OF THE C MATRIX. (= NN) C M - INPUT SCALAR CONTAINING THE NUMBER OF C SMALLEST EIGENVALUES DESIRED (M IS C LESS THAN OR EQUAL TO N). C ISW - INPUT SCALAR MEANING AS FOLLOWS - C ISW=1 MEANS THAT THE MATRIX IS KNOWN TO BE C POSITIVE DEFINITE. C ISW=0 MEANS THAT THE MATRIX IS NOT KNOWN C TO BE POSITIVE DEFINITE. C IER - ERROR PARAMETER. (OUTPUT) (= IERR) C WARNING ERROR C IER = 601 INDICATES THAT SUCCESSIVE C ITERATES TO THE K-TH EIGENVALUE WERE NOT C MONOTONE INCREASING. THE VALUE K IS C STORED IN E2(1). C TERMINAL ERROR C IER = 602 INDICATES THAT ISW=1 BUT MATRIX C IS NOT POSITIVE DEFINITE C C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 C - SINGLE/H36,H48,H60 C C C NOTATION - INFORMATION ON SPECIAL NOTATION AND C CONVENTIONS IS AVAILABLE IN THE MANUAL C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP C C REMARKS AS WRITTEN, THE ROUTINE COMPUTES THE M SMALLEST C EIGENVALUES. TO COMPUTE THE M LARGEST EIGENVALUES, C REVERSE THE SIGN OF EACH ELEMENT OF D BEFORE AND C AFTER CALLING THE ROUTINE. IN THIS CASE, ISW MUST C EQUAL ZERO. C C COPYRIGHT - 1980 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C C SPECIFICATIONS FOR ARGUMENTS INTEGER NN,M,ISW,IERR REAL D(NN),E2(NN) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER II,I,JJ,J,K1,K,N,IER REAL DELTA,DLAM,EP,ERR,F,P,QP,Q,R,S,TOT C C C SRELPR = MACHINE PRECISION C FIRST EXECUTABLE STATEMENT N = NN IER = 0 DLAM = 0.0E0 ERR = 0.0E0 S = 0.0E0 C LOOK FOR SMALL SUB-DIAGONAL ENTRIES C DEFINE INITIAL SHIFT FROM LOWER C GERSCHGORIN BOUND. TOT = D(1) Q = 0.0E0 J = 0 DO 15 I=1,N P = Q IF (I.EQ.1) GO TO 5 IF (P.GT.SRELPR*(ABS(D(I))+ABS(D(I-1)))) GO TO 10 5 E2(I) = 0.0E0 C COUNT IF E2(I) HAS UNDERFLOWED 10 IF (E2(I) .EQ. 0.E0) J = J+1 Q = 0.0E0 IF (I.NE.N) Q = SQRT(ABS(E2(I+1))) TOT = AMIN1(D(I)-P-Q,TOT) 15 CONTINUE IF (ISW.EQ.1.AND.TOT.LT.0.0E0) GO TO 25 DO 20 I=1,N 20 D(I) = D(I)-TOT GO TO 30 25 TOT = 0.0E0 30 DO 90 K=1,M C NEXT QR TRANSFORMATION 35 TOT = TOT+S DELTA = D(N)-S I = N F = ABS(SRELPR*TOT) IF (DLAM.LT.F) DLAM = F IF (DELTA.GT.DLAM) GO TO 40 IF (DELTA.GE.(-DLAM)) GO TO 75 IER = 602 IF(LEVEL .GE. 1) WRITE(NOUT,37) 37 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H , 30H IN ITPACK ROUTINE EQRT1S B / 1H , 35H PARAMETER ISW = 1 BUT MATRIX C / 1H , 25H NOT POSITIVE DEFINITE ) GO TO 9000 C REPLACE SMALL SUB-DIAGONAL SQUARES C BY ZERO TO REDUCE THE INCIDENCE OF C UNDERFLOWS 40 IF (K.EQ.N) GO TO 50 K1 = K+1 DO 45 J=K1,N IF (E2(J).LE.(SRELPR*(D(J)+D(J-1)))**2) E2(J) = 0.0E0 45 CONTINUE 50 F = E2(N)/DELTA QP = DELTA+F P = 1.0E0 IF (K.EQ.N) GO TO 65 K1 = N-K DO 60 II=1,K1 I = N-II Q = D(I)-S-F R = Q/QP P = P*R+1.0E0 EP = F*R D(I+1) = QP+EP DELTA = Q-EP IF (DELTA.GT.DLAM) GO TO 55 IF (DELTA.GE.(-DLAM)) GO TO 75 IER = 602 IF(LEVEL .GE. 0) WRITE(NOUT,37) GO TO 9000 55 F = E2(I)/Q QP = DELTA+F E2(I+1) = QP*EP 60 CONTINUE 65 D(K) = QP S = QP/P IF (TOT+S.GT.TOT) GO TO 35 IER = 601 E2(1) = K IF(LEVEL .GE. 1) WRITE(NOUT,67) K 67 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 30H IN ITPACK ROUTINE EQRT1S B / 1H , 30H SUCCESSIVE ITERATES TO THE ,I10 C / 1H , 44H EIGENVALUE WERE NOT MONOTONE INCREASING ) C SET ERROR -- IRREGULAR END C DEFLATE MINIMUM DIAGONAL ELEMENT S = 0.0E0 DELTA = QP DO 70 J=K,N IF (D(J).GT.DELTA) GO TO 70 I = J DELTA = D(J) 70 CONTINUE C CONVERGENCE 75 IF (I.LT.N) E2(I+1) = E2(I)*F/QP IF (I.EQ.K) GO TO 85 K1 = I-K DO 80 JJ=1,K1 J = I-JJ D(J+1) = D(J)-S E2(J+1) = E2(J) 80 CONTINUE 85 D(K) = TOT ERR = ERR+ABS(DELTA) E2(K) = ERR 90 CONTINUE IF (IER.EQ.0) GO TO 9005 9000 CONTINUE 9005 IERR = IER RETURN END INTEGER FUNCTION IPSTR (OMEGA) IPST0010 C C FINDS THE SMALLEST INTEGER, IPSTR, GREATER THAN 5 SUCH THAT C IPSTR * (OMEGA-1)**(IPSTR-1) .LE. 0.50. IPSTR WILL BE SET C IN LOOP. C C ... PARAMETER LIST: C C OMEGA RELAXATION FACTOR FOR SOR METHOD C C ... SPECIFICATIONS FOR ARGUMENTS C REAL OMEGA C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IP REAL WM1 C WM1 = OMEGA - 1.E0 C DO 10 IP=6,940 IF ( FLOAT(IP)*(WM1**(IP-1)) .GT. 0.50E0 ) GO TO 10 IPSTR = IP RETURN 10 CONTINUE IPSTR = 940 RETURN C END SUBROUTINE ITERM(NN,A,U,WK,IMTHDD) ITER0010 C C THIS ROUTINE PRODUCES THE ITERATION SUMMARY LINE AT THE END C OF EACH ITERATION. IF LEVEL = 5, THE LATEST APPROXIMATION C TO THE SOLUTION WILL BE PRINTED. C C ... PARAMETER LIST: C C NN ORDER OF SYSTEM OR, FOR REDUCED SYSTEM C ROUTINES, ORDER OF BLACK SUBSYSTEM C A ITERATION MATRIX C U SOLUTION ESTIMATE C WK WORK ARRAY OF LENGTH NN C IMTHD INDICATOR OF METHOD (=IMTHDD) C IMTHD = 1, JCG C IMTHD = 2, JSI C IMTHD = 3, SOR C IMTHD = 4, SSORCG C IMTHD = 5, SSORSI C IMTHD = 6, RSCG C IMTHD = 7, RSSI C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER NN, IMTHD REAL A(1), U(NN), WK(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, IMTHDD, IP, N REAL QTFF C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C N = NN IMTHD = IMTHDD C C ... PRINT VARIOUS PARAMETERS AFTER EACH ITERATION C IF (LEVEL .LT. 2) RETURN GO TO (5,48,54,70,30,5,48), IMTHD 5 IF (IN .GT. 0) GO TO 20 C C ... PRINT HEADER FOR JCG AND RSCG C WRITE(NOUT,10) 10 FORMAT(////15X,40HINTERMEDIATE OUTPUT AFTER EACH ITERATION A //10H NUMBER OF ,5X,11HCONVERGENCE , B 7X,4HCME ,11X,3HRHO,12X,5HGAMMA C /11H ITERATIONS,4X,5HTEST //) C C ... PRINT SUMMARY LINE C 20 WRITE(NOUT,25) IN,STPTST,CME,RHO,GAMMA 25 FORMAT(4X,I5,3X,4E15.7) IF (LEVEL .GE. 4) GO TO 90 C RETURN C 30 IF (IN .GT. 0) GO TO 40 C C ... PRINT HEADER FOR SSOR-SI C WRITE(NOUT,35) 35 FORMAT(////15X,40HINTERMEDIATE OUTPUT AFTER EACH ITERATION A //10H NUMBER OF ,4X,11HCONVERGENCE , B 7X,21HPARAMETER CHANGE TEST,10X,3HRHO, C 12X,5HGAMMA/11H ITERATIONS,3X,5HTEST , D 11X,7HLHS(QA),7X,11HRHS(QT**FF)//) C C ... PRINT SUMMARY LINE C 40 IP = IN - IS IF (IMTHD .EQ. 7) IP = 2*IP IF (IP .LT. 3) GO TO 46 QTFF = QT**FF WRITE(NOUT,45) IN,STPTST,QA,QTFF,RHO,GAMMA 45 FORMAT(4X,I5,3X,5E15.7) IF (LEVEL .GE. 4) GO TO 90 RETURN C 46 WRITE(NOUT,47) IN,STPTST,RHO,GAMMA 47 FORMAT(4X,I5,3X,E15.7,30X,2E15.7) IF (LEVEL .GE. 4) GO TO 90 RETURN C 48 IF (IN .GT. 0) GO TO 50 C C ... PRINT HEADER FOR J-SI AND RS-SI C WRITE(NOUT,49) 49 FORMAT(////15X,40HINTERMEDIATE OUTPUT AFTER EACH ITERATION A //10H NUMBER OF ,4X,11HCONVERGENCE , B 7X,21HPARAMETER CHANGE TEST,10X,3HRHO C /11H ITERATIONS,3X,5HTEST , D 11X,7HLHS(QA),7X,11HRHS(QT**FF)//) C C ... PRINT SUMMARY LINE C 50 IP = IN - IS IF (IMTHD .EQ. 7) IP = 2*IP IF (IP .LT. 3) GO TO 52 QTFF = QT**FF WRITE(NOUT,51) IN,STPTST,QA,QTFF,RHO 51 FORMAT(4X,I5,3X,5E15.7) IF (LEVEL .GE. 4) GO TO 90 RETURN C 52 WRITE(NOUT,53) IN,STPTST,RHO 53 FORMAT(4X,I5,3X,E15.7,30X,E15.7) IF (LEVEL .GE. 4) GO TO 90 RETURN C C ... PRINT VARIOUS PARAMETERS AFTER EACH ITERATION FOR SOR. C 54 IF (IN .GT. 0) GO TO 60 C C ... PRINT HEADER FOR SOR C WRITE(NOUT,55) 55 FORMAT(////15X,40HINTERMEDIATE OUTPUT AFTER EACH ITERATION A //10H NUMBER OF,4X,11HCONVERGENCE,6X, B 4HCME ,9X,5HOMEGA,7X,8HSPECTRAL /11H ITERATIONS, C 3X,4HTEST,38X,6HRADIUS //) C C ... PRINT SUMMARY LINE FOR SOR C 60 CONTINUE WRITE(NOUT,65) IN,STPTST,CME,OMEGA,SPECR 65 FORMAT(4X,I5,3X,4E14.7) IF (LEVEL .GE. 4) GO TO 90 C RETURN C C ... PRINT VARIOUS PARAMETERS AFTER EACH ITERATION FOR SSOR-CG. C 70 IF (IN .GT. 0) GO TO 80 C C ... PRINT HEADER FOR SSOR-CG C WRITE(NOUT,75) 75 FORMAT(////15X,40HINTERMEDIATE OUTPUT AFTER EACH ITERATION A //10H NUMBER OF,4X,11HCONVERGENCE,3X, B 9H SPECTRAL,6X,7HS-PRIME, C 9X,3HRHO,10X,5HGAMMA /11H ITERATIONS, D 3X,5HTEST ,10X,6HRADIUS //) C C ... PRINT SUMMARY LINE FOR SSOR-CG C 80 CONTINUE WRITE(NOUT,85) IN,STPTST,SPECR,SPR,RHO,GAMMA 85 FORMAT(4X,I5,3X,5E14.7) IF (LEVEL .GE. 4) GO TO 90 RETURN C 90 IF (IMTHD .GT. 5) GO TO 92 WRITE (NOUT,91) IN 91 FORMAT (1H0,2X,34HESTIMATE OF SOLUTION AT ITERATION ,I5) GO TO 94 92 WRITE (NOUT,93) IN 93 FORMAT (1H0,2X,37HESTIMATE OF SOLUTION AT BLACK POINTS , A 13HAT ITERATION ,I5) 94 DO 95 I=1,N 95 WK(I) = U(I)/A(I) WRITE (NOUT,100) (WK(I),I=1,N) 100 FORMAT (2X,5(2X,G20.13)) WRITE (NOUT,105) 105 FORMAT (//) C RETURN END SUBROUTINE IVFILL(N,IV,IVAL) IVFI0010 C C FILLS AN INTEGER VECTOR, IV, WITH AN INTEGER VALUE, IVAL. C C ... PARAMETER LIST: C C N INTEGER LENGTH OF VECTOR IV C IV INTEGER VECTOR C IVAL INTEGER CONSTANT THAT FILLS FIRST N LOCATIONS OF IV C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N, IVAL, IV(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, M, MP1 C IF (N .LE. 0) RETURN C C CLEAN UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 10 C M = MOD(N,10) IF (M .EQ. 0) GO TO 20 DO 10 I = 1,M 10 IV(I) = IVAL IF (N .LT. 10) RETURN C 20 MP1 = M + 1 DO 30 I = MP1,N,10 IV(I ) = IVAL IV(I+1) = IVAL IV(I+2) = IVAL IV(I+3) = IVAL IV(I+4) = IVAL IV(I+5) = IVAL IV(I+6) = IVAL IV(I+7) = IVAL IV(I+8) = IVAL IV(I+9) = IVAL 30 CONTINUE C RETURN END SUBROUTINE OMEG(DNRM,IFLAG) OMEG0010 C C COMPUTES NEW VALUES FOR CME, OMEGA, AND SPECR FOR C FULLY ADAPTIVE SSOR METHODS. C C ... PARAMETER LIST: C C DNRM NUMERATOR OF RAYLEIGH QUOTIENT C IFLAG INDICATOR OF APPROPRIATE ENTRY POINT C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IFLAG REAL DNRM C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL TEMP, ZM1, ZM2 C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C ZM1 = 0.E0 ZM2 = 0.E0 IF (IFLAG .EQ. 1) GO TO 20 C C ... IFLAG .NE. 1, COMPUTE NEW ESTIMATE FOR CME C ZM1 = ((1.E0-SPR)*(1.E0+BETAB*OMEGA**2) - OMEGA*(2.E0-OMEGA)) A / (OMEGA * (OMEGA - 1.E0 - SPR)) C IF(.NOT.CASEII) ZM2 = DNRM / BDELNM IF(CASEII) ZM2 = SQRT(ABS(DNRM/BDELNM)) CME = AMAX1(CME,ZM1,ZM2) C C ... IFLAG = 1, OR CONTINUATION OF IFLAG .NE. 1 C C COMPUTE NEW VALUES OF OMEGA AND SPECR BASED ON CME AND BETAB C 20 IS = IN + 1 DELSNM = DELNNM IF (CME .GE. (4.E0 * BETAB)) GO TO 40 C C ... CME .LT. 4.E0*BETAB C TEMP = SQRT(ABS(1.E0 - 2.E0*CME + 4.E0*BETAB)) OMEGA = AMAX1( (2.E0/(1.E0 + TEMP)) , 1.E0) TEMP = (1.E0 - CME) / TEMP SPECR = (1.E0 - TEMP) / (1.E0 + TEMP) IF (ABS(OMEGA - 1.E0) .LT. SRELPR) SPECR = 0.E0 IF (LEVEL .GE. 2) WRITE(NOUT,30) IN,BETAB,ZM1,ZM2,CME,OMEGA, A SPECR 30 FORMAT(/30X,40HPARAMETERS WERE CHANGED AT ITERATION NO. ,I5 A /35X,34HNEW ESTIMATE OF BETAB =,E15.7 A /35X,34HSOLUTION TO CHEBYSHEV EQN. =,E15.7 B /35X,34HSOLUTION TO RAYLEIGH QUOTIENT =,E15.7 C /35X,34HNEW ESTIMATE FOR CME =,E15.7 D /35X,34HNEW ESTIMATE FOR OMEGA =,E15.7 E /35X,34HNEW ESTIMATE FOR SPECTRAL RADIUS =,E15.7 /) C RETURN C C ... CME .GE. 4.E0*BETAB C C ... OMEGA-STAR WILL BE CHOSEN C 40 CME = 2.E0 * SQRT(ABS(BETAB)) OMEGA = 2.E0/(1.E0 + SQRT(ABS(1.E0 - 4.E0*BETAB))) SPECR = OMEGA - 1.E0 ADAPT = .FALSE. PARTAD = .FALSE. IF (LEVEL .GE. 2) WRITE(NOUT,30) IN,BETAB,ZM1,ZM2,CME,OMEGA, A SPECR C RETURN END LOGICAL FUNCTION OMGCHG (NDUMMY) OMGC0010 C C ... THIS FUNCTION TESTS TO SEE WHETHER OMEGA SHOULD BE CHANGED C ... FOR SSOR CG METHOD. C C ... PARAMETER LIST: C C NDUMMY ARBITRARY INTEGER PARAMETER C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER NDUMMY C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL DEL1, DEL2, X C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C C ... STATEMENT FUNCTION PHI(X) C PHI(X) = (1.E0 - SQRT(ABS(1.E0 - X))) / A (1.E0 + SQRT(ABS(1.E0 - X))) C OMGCHG = .FALSE. IF (IN - IS .LT. 3) RETURN IF (SPECR .EQ. 0.E0) GO TO 10 IF (SPECR .GT. SPR) RETURN DEL1 = -ALOG(ABS(PHI(SPECR)/PHI(SPECR/SPR))) DEL2 = -ALOG(ABS(PHI(SPR))) IF ((DEL1/DEL2) .GE. FF) RETURN C 10 OMGCHG = .TRUE. C RETURN END LOGICAL FUNCTION OMGSTR (NDUMMY) OMGS0010 C C TESTS FOR FULLY ADAPTIVE SSOR METHODS WHETHER OMEGA-STAR C SHOULD BE USED FOR OMEGA AND THE ADAPTIVE PROCESS TURNED C OFF. C C ... PARAMETER LIST: C C NDUMMY ARBITRARY INTEGER PARAMETER C C ... SPECIFICATION FOR ARGUMENT C INTEGER NDUMMY C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL OMSTAR, TEMP, TEMP1, X C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C C ... STATEMENT FUNCTION PHI(X) C PHI(X) = (1.E0 - SQRT(ABS(1.E0-X))) / (1.E0 + SQRT(ABS(1.E0-X))) C OMGSTR = .FALSE. IF (BETAB .GE. .25E0 .OR. .NOT.ADAPT) RETURN OMSTAR = 2.E0 / (1.E0 + SQRT(ABS(1.E0 - 4.E0*BETAB))) C C ... TEST TO CHOSE OMEGA-STAR C IF ((OMSTAR .LE. 1.E0) .OR. (SPECR .LE. 0.E0)) GO TO 10 TEMP = ALOG(ABS(PHI (OMSTAR - 1.E0))) TEMP1 = ALOG(ABS(PHI(SPECR))) IF ((TEMP/TEMP1) .LT. FF) RETURN C C ... OMEGA-STAR WAS CHOSEN C 10 OMEGA = OMSTAR SPECR = OMEGA - 1.E0 OMGSTR = .TRUE. ADAPT = .FALSE. PARTAD = .FALSE. CME = 2.E0 * SQRT(ABS(BETAB)) RRR = PHI(1.E0 - SPECR) ** 2 GAMMA = 2.E0 / (2.E0 - SPECR) SIGE = SPECR / (2.E0 - SPECR) RHO = 1.E0 IS = IN + 1 DELSNM = DELNNM IF(LEVEL .GE. 2) WRITE(NOUT,20) IN,CME,OMEGA,SPECR 20 FORMAT(/30X,36HOMEGA-STAR, AN ALTERNATE ESTIMATE OF A ,31H OMEGA, WAS CHOSEN AT ITERATION ,I5 B /35X,34HNEW ESTIMATE FOR CME = ,E15.7 C /35X,34HNEW ESTIMATE FOR OMEGA = ,E15.7 D /35X,34HNEW ESTIMATE FOR SPECTRAL RADIUS = ,E15.7 /) C RETURN END SUBROUTINE PARCON(DTNRM,C1,C2,C3,C4,GAMOLD,RHOTMP,IBMTH) PARC0010 C C COMPUTES ACCELERATION PARAMETERS FOR CONJUGATE GRADIENT C ACCELERATED METHODS. C C ... PARAMETER LIST: C C DTNRM INNER PRODUCT OF RESIDUALS C C1 OUTPUT: RHO*GAMMA C C2 OUTPUT: RHO C C3 OUTPUT: 1-RHO C C4 OUTPUT: RHO*(1-GAMMA) C GAMOLD OUTPUT: VALUE OF GAMMA AT PRECEDING ITERATION C RHOTMP LAST ESTIMATE FOR VALUE OF RHO C IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY CG C IBMTH = 1, JACOBI C = 2, REDUCED SYSTEM C = 3, SSOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IBMTH REAL DTNRM, C1, C2, C3, C4, GAMOLD, RHOTMP C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IP REAL RHOOLD C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C IP = IN - IS C C ... SET RHOOLD AND GAMOLD C RHOOLD = RHO GAMOLD = GAMMA C C ... COMPUTE GAMMA (IN+1) C C ... FOR JACOBI OR REDUCED SYSTEM CG IF (IBMTH .LE. 2) GAMMA = 1.E0 / A (1.E0 - DTNRM/DELNNM ) C C ... FOR SSOR CG IF (IBMTH .EQ. 3) GAMMA = DELNNM / DTNRM C C ... COMPUTE RHO (IN+1) C RHO = 1.E0 IF (IP .EQ. 0) GO TO 20 IF(ISYM .EQ. 0) GO TO 12 RHO = 1.E0 / (1.E0 - GAMMA*RHOTMP/DELSNM) GO TO 20 12 RHO = 1.E0 / (1.E0 - GAMMA*DELNNM/(GAMOLD*DELSNM*RHOOLD)) C C ... COMPUTE CONSTANTS C1, C2, C3, AND C4 C 20 DELSNM = DELNNM RHOTMP = RHOOLD C1 = RHO * GAMMA C2 = RHO C3 = 1.E0 - RHO C4 = RHO * ( 1.E0 - GAMMA ) C C RETURN END SUBROUTINE PARSI(C1,C2,C3,IBMTH) PARS0010 C C COMPUTES ACCELERATION PARAMETERS FOR SEMI-ITERATIVE C ACCELERATED METHODS. C C ... PARAMETER LIST: C C C1,C2 C AND C C3 OUTPUT ACCELERATION PARAMETERS C IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY SI C IBMTH = 1, JACOBI C = 2, REDUCED SYSTEM C = 3, SSOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IBMTH REAL C1, C2, C3 C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IP C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C IP = IN - IS IF (IP .EQ. 0) GO TO 30 IF (IP .EQ. 1) GO TO 10 RHO = 1.E0/(1.E0 - SIGE*SIGE*RHO*.25E0) GO TO 20 10 RHO = 1.E0/(1.E0 - SIGE*SIGE*.5E0) C 20 C1 = RHO * GAMMA C2 = RHO C3 = 1.E0 - RHO C RETURN C C ... NONADAPTIVE INITIALIZATION FOR SEMI-ITERATIVE METHODS C 30 CONTINUE GO TO (40,50,60),IBMTH C C ... JSI C 40 IF (CASEII) SME = -CME GAMMA = 2.E0 / ( 2.E0 - CME - SME ) SIGE = ( CME - SME ) / ( 2.E0 - CME - SME ) GO TO 70 C C ... REDUCED SYSTEM SI C 50 GAMMA = 2.E0 / (2.E0 - CME*CME) SIGE = CME*CME / (2.E0 - CME*CME) RRR = (1.E0 - SQRT(ABS(1.E0-CME*CME))) / A (1.E0 + SQRT(ABS(1.E0-CME*CME))) GO TO 70 C C ... SSORSI C 60 GAMMA = 2.E0/(2.E0 - SPECR) SIGE = SPECR/(2.E0 - SPECR) RRR = (1.E0 - SQRT(ABS(1.E0-SIGE*SIGE))) / A (1.E0 + SQRT(ABS(1.E0-SIGE*SIGE))) C 70 RHO = 1.E0 C1 = GAMMA C2 = 1.E0 C3 = 0.E0 C RETURN END REAL FUNCTION PBETA (NN,IA,JA,A,V,W1,W2) PBET0010 C C ... COMPUTES THE NUMERATOR FOR THE COMPUTATION OF BETAB IN C ... SSOR METHODS. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX (= NN) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C W1,W2 WORKSPACE VECTORS OF LENGTH N C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), V(NN), W1(NN), W2(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, IBGN, IEND, II, ITMP, JAI, JAJJ, JJ, K, N, NM1 REAL SUM, TEMP1, TEMP2 C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C N = NN PBETA = 0.E0 IF (ISYM.EQ.0) GO TO 110 C C ************** NON - SYMMETRIC SECTION ******************** C DO 10 I = 1,N 10 W1(I) = V(I) TEMP1 = 0.E0 TEMP2 = 0.E0 ITMP = 2 IBGN = IA(1) IEND = IA(ITMP)-1 IF (IEND.LT.IBGN) GO TO 30 DO 20 I = IBGN,IEND JAI = JA(I) 20 TEMP1 = TEMP1-A(I)*W1(JAI) 30 W1(1) = TEMP1 W2(1) = 0.E0 NM1 = N-1 DO 70 K = 2,NM1 TEMP1 = 0.E0 TEMP2 = 0.E0 IBGN = IA(K) IEND = IA(K+1)-1 IF (IEND.LT.IBGN) GO TO 60 DO 50 I = IBGN,IEND JAI = JA(I) IF (JAI.GT.K) GO TO 40 TEMP2 = TEMP2-A(I)*W1(JAI) GO TO 50 40 TEMP1 = TEMP1-A(I)*W1(JAI) 50 CONTINUE 60 W1(K) = TEMP1 W2(K) = TEMP2 70 CONTINUE TEMP2 = 0.E0 IBGN = IA(N) IEND = IA(N+1)-1 IF (IEND.LT.IBGN) GO TO 90 DO 80 I = IBGN,IEND JAI = JA(I) 80 TEMP2 = TEMP2-A(I)*W1(JAI) 90 W2(N) = TEMP2 DO 100 I = 1,N 100 PBETA = PBETA+V(I)*W2(I) RETURN C C **************** SYMMETRIC SECTION ************************* C 110 DO 130 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 SUM = 0.E0 IF (IBGN.GT.IEND) GO TO 130 DO 120 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*V(JAJJ) 120 CONTINUE PBETA = PBETA+SUM*SUM 130 CONTINUE RETURN C END SUBROUTINE PBSOR (NN,IA,JA,A,U,RHS) PBSO0010 C C ... THIS SUBROUTINE COMPUTES A BACKWARD SOR SWEEP. C C ... PARAMETER LIST: C C N ORDER OF SYSTEM (= NN) C OMEGA RELAXATION FACTOR C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C U LATEST ESTIMATE OF SOLUTION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), U(NN), RHS(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, IBGN, IEND, II, JAJJ, JJ, N, NPL1 REAL OMM1, SUM, UI C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C N = NN NPL1 = N+1 OMM1 = OMEGA-1.E0 IF (ISYM.EQ.0) GO TO 40 C C *************** NON - SYMMETRIC SECTION ********************** C DO 30 I = 1,N II = NPL1-I IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 20 DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 10 CONTINUE 20 U(II) = OMEGA*SUM-OMM1*U(II) 30 CONTINUE RETURN C C ***************** SYMMETRIC SECTION ************************** C 40 DO 60 II = 1,N UI = U(II) IBGN = IA(II) IEND = IA(II+1)-1 IF (IBGN.GT.IEND) GO TO 60 DO 50 JJ = IBGN,IEND JAJJ = JA(JJ) RHS(JAJJ) = RHS(JAJJ)-A(JJ)*UI 50 CONTINUE 60 CONTINUE C DO 90 I = 1,N II = NPL1-I IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 80 DO 70 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 70 CONTINUE 80 U(II) = OMEGA*SUM-OMM1*U(II) 90 CONTINUE RETURN C END SUBROUTINE PERMAT ( NN,IA,JA,A,P,NEWIA,ISYM,LEVEL,NOUT,IERR ) PERM0010 C C********************************************************************* C C ... SUBROUTINE PERMAT TAKES THE SPARSE MATRIX REPRESENTATION C OF THE MATRIX STORED IN THE ARRAYS IA, JA, AND A AND C PERMUTES BOTH ROWS AND COLUMNS OVERWRITING THE PREVIOUS C STRUCTURE. C C ... PARAMETER LIST: C C N ORDER OF SYSTEM (= NN) C IA,JA INTEGER ARRAYS OF THE SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF THE SPARSE MATRIX REPRESENTATION C P PERMUTATION VECTOR C NEWIA INTEGER WORK VECTOR OF LENGTH N C ISYM SYMMETRIC/NONSYMMETRIC STORAGE SWITCH C LEVEL SWITCH CONTROLLING LEVEL OF OUTPUT C NOUT OUTPUT UNIT NUMBER C IER OUTPUT ERROR FLAG (= IERR) C C IER = 0 NORMAL RETURN C IER = 301 NO ENTRY IN ITH ROW OF ORIGINAL C MATRIX. IF LEVEL IS GREATER THAN C 0, I WILL BE PRINTED C IER = 302 THERE IS NO ENTRY IN THE ITH ROW C OF THE PERMUTED MATRIX C IER = 303 ERROR RETURN FROM QSORT IN C SORTING THE ITH ROW OF THE C PERMUTED MATRIX C ... IT IS ASSUMED THAT THE I-TH ENTRY OF THE PERMUTATION VECTOR C P INDICATES THE ROW THE I-TH ROW GETS MAPPED INTO. (I.E. C IF ( P(I) = J ) ROW I GETS MAPPED INTO ROW J.) C C ... THE ARRAY NEWIA IS AN INTEGER WORK VECTOR OF LENGTH N WHICH C KEEPS TRACK OF WHERE THE ROWS BEGIN IN THE PERMUTED STRUCTURE. C C ... PERMAT IS CAPABLE OF PERMUTING BOTH THE SYMMETRIC AND NON- C SYMMETRIC FORM OF IA, JA, AND A. IF ( ISYM .EQ. 0 ) SYMMETRIC C FORM IS ASSUMED. C C ... TWO EXTERNAL MODULES ARE USED BY PERMAT. THE FIRST IS INTEGER C FUNCTION BISRCH WHICH USES A BISECTION SEARCH ( ORDER LOG-BASE-2 C OF N+1 ) THROUGH THE ARRAY IA TO FIND THE ROW INDEX OF AN ARBI- C TRARY ENTRY EXTRACTED FROM THE ARRAY JA. THE SECOND IS SUBROUTINE C QSORT WHICH PERFORMS A QUICK SORT TO PLACE THE ENTRIES IN C THE PERMUTED ROWS IN COLUMN ORDER. C C********************************************************************* C INTEGER NN, IA(1), JA(1), P(NN), NEWIA(NN), ISYM, IERR REAL A(1) C C ... INTERNAL VARIABLES C INTEGER BISRCH, I, IBGN, IEND, IP, IPP, J, JAJ, JP, IER A K, N, NELS, NEXT, NPL1 C REAL SAVE, TEMP C C********************************************************************* C C ... PREPROCESSING PHASE C C ...... DETERMINE THE NUMBER OF NONZEROES IN THE ROWS OF THE PERMUTED C MATRIX AND STORE THAT IN NEWIA. THEN SWEEP THRU NEWIA TO MAKE C NEWIA(I) POINT TO THE BEGINNING OF EACH ROW IN THE PERMUTED C DATA STRUCTURE. ALSO NEGATE ALL THE ENTRIES IN JA TO INDICATE C THAT THOSE ENTRIES HAVE NOT BEEN MOVED YET. C N=NN IER = 0 NPL1 = N + 1 NELS = IA(NPL1) - 1 DO 10 I = 1, N NEWIA(I) = 0 10 CONTINUE DO 40 I = 1, N IP = P(I) IBGN = IA(I) IEND = IA(I+1) - 1 IF ( IBGN .GT. IEND ) GO TO 200 DO 30 J = IBGN, IEND IPP = IP JAJ = JA(J) JP = P(JAJ) IF ( ISYM .EQ. 0 .AND. IP .GT. JP ) IPP = JP NEWIA(IPP) = NEWIA(IPP) + 1 JA(J) = -JAJ 30 CONTINUE 40 CONTINUE IBGN = 1 DO 50 I = 1, N K = IBGN + NEWIA(I) NEWIA(I) = IBGN IBGN = K 50 CONTINUE C C ...... PREPROCESSING NOW FINISHED. C C ...... NOW PERMUTE JA AND A. THIS PERMUTATION WILL PERFORM THE C FOLLOWING STEPS C C 1. FIND THE FIRST ENTRY IN JA NOT PERMUTED WHICH IS C INDICATED BY AN NEGATIVE VALUE IN JA C 2. COMPUTE WHICH ROW THE CURRENT ENTRY IS IN. THIS C IS COMPUTED BY A BISECTION SEARCH THRU THE ARRAY C IA. C 3. USING THE PERMUTATION ARRAY P AND THE ARRAY NEWIA C COMPUTE WHERE THE CURRENT ENTRY IS TO BE PLACED. C 4. THEN PICK UP THE ENTRY WHERE THE CURRENT ENTRY WILL C GO. PUT THE CURRENT ENTRY IN PLACE. THEN MAKE THE C DISPLACED ENTRY THE CURRENT ENTRY AND LOOP TO STEP 2. C 5. THIS PROCESS WILL END WHEN THE NEXT ENTRY HAS ALREADY C BEEN MOVED. THEN LOOP TO STEP 1. C DO 80 J = 1, NELS IF ( JA(J) .GT. 0 ) GO TO 80 JAJ = -JA(J) SAVE = A(J) NEXT = J JA(J) = JAJ C 60 JP = P(JAJ) I = BISRCH ( NPL1, IA, NEXT ) IP = P(I) IPP = IP IF ( ISYM .NE. 0 .OR. IP .LE. JP ) GO TO 70 IPP = JP JP = IP 70 NEXT = NEWIA(IPP) C TEMP = SAVE SAVE = A(NEXT) A(NEXT) = TEMP C JAJ = -JA(NEXT) JA(NEXT) = JP NEWIA(IPP) = NEWIA(IPP) + 1 IF ( JAJ .GT. 0 ) GO TO 60 C 80 CONTINUE C C ...... THE MATRIX IS NOW PERMUTED BUT THE ROWS MAY NOT BE IN C ORDER. THE REMAINDER OF THIS SUBROUTINE PERFORMS C A QUICK SORT ON EACH ROW TO SORT THE ENTRIES IN C COLUMN ORDER. THE IA ARRAY IS ALSO CORRECTED FROM C INFORMATION STORED IN THE NEWIA ARRAY. NEWIA(I) NOW C POINTS TO THE FIRST ENTRY OF ROW I+1. C IA(1) = 1 DO 100 I = 1, N IA(I+1) = NEWIA(I) K = IA(I+1) - IA(I) IF ( K .EQ. 1 ) GO TO 100 IF ( K .LT. 1 ) GO TO 210 C IBGN = IA(I) CALL QSORT ( K, JA(IBGN), A(IBGN), IER ) IF ( IER .NE. 0 ) GO TO 220 C 100 CONTINUE C C ...... END OF MATRIX PERMUTATION C GO TO 230 C C ... ERROR TRAPS C C ...... NO ENTRY IN ROW I IN THE ORIGINAL SYSTEM C 200 IER = 301 IF(LEVEL .GE. 0) WRITE(NOUT,205) I 205 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE PERMAT B / 1H , 20H NO ENTRY IN ROW ,I10,20H OF ORIGINAL MATRIX ) GO TO 230 C C ...... NO ENTRY IN ROW I IN THE PERMUTED SYSTEM C 210 IER = 302 IF(LEVEL .GE. 0) WRITE(NOUT,215) I 215 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE PRBNDX B / 1H , 20H NO ENTRY IN ROW ,I10,20H OF PERMUTED MATRIX ) GO TO 230 C C ...... ERROR RETURN FROM SUBROUTINE QSORT C 220 IER = 303 IF(LEVEL .GE. 0) WRITE(NOUT,225) I 225 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE QSORT B / 1H , 34H ERROR IN SORTING PERMUTED ROW ,I12 C / 1H , 40H CALLED FROM ITPACK ROUTINE PRBNDX ) C 230 CONTINUE IERR = IER RETURN END SUBROUTINE PERROR(NN,IA,JA,A,RHS,U,W,DIGTT1,DIGTT2,IDGTTS) PERR0010 C C PERROR COMPUTES THE RESIDUAL, R = RHS - A*U. THE USER C ALSO HAS THE OPTION OF PRINTING THE RESIDUAL AND/OR THE C UNKNOWN VECTOR DEPENDING ON IDGTS. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX (= NN) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C U LATEST ESTIMATE OF SOLUTION C W WORKSPACE VECTOR C DIGIT1 OUTPUT: MEASURE OF ACCURACY OF STOPPING TEST (= DIGTT1 C DIGIT2 OUTPUT: MEASURE OF ACCURACY OF SOLUTION (= DIGTT2) C IDGTS PARAMETER CONTROLING LEVEL OF OUTPUT (= IDGTTS) C IF IDGTS < 1 OR IDGTS > 4, THEN NO OUTPUT. C = 1, THEN NUMBER OF DIGITS IS PRINTED, PRO- C VIDED LEVEL .GE. 1 C = 2, THEN SOLUTION VECTOR IS PRINTED, PRO- C VIDED LEVEL .GE. 1 C = 3, THEN RESIDUAL VECTOR IS PRINTED, PRO- C VIDED LEVEL .GE. 1 C = 4, THEN BOTH VECTORS ARE PRINTED, PRO- C VIDED LEVEL .GE. 1 C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN, IDGTTS REAL A(1), RHS(NN), U(NN), W(NN), A DIGTT1, DIGTT2 C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IDGTS, N REAL BNRM, DIGIT1, DIGIT2, RNRM, TEMP C C ... SPECIFICATIONS FOR FUNCTION SUBPROGRAMS C REAL SDOT C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C C N = NN IDGTS = IDGTTS DIGIT1 = 0.E0 DIGIT2 = 0.E0 IF (N .LE. 0) GO TO 20 C DIGIT1 = -ALOG10(ABS(SRELPR)) IF (STPTST .GT. 0.E0) DIGIT1 = -ALOG10(ABS(STPTST)) BNRM = SDOT(N,RHS,1,RHS,1) IF(BNRM .EQ. 0.E0) GO TO 10 CALL PMULT(N,IA,JA,A,U,W) CALL WEVMW(N,RHS,W) RNRM = SDOT(N,W,1,W,1) TEMP=RNRM/BNRM IF(TEMP .EQ. 0.E0) GO TO 10 DIGIT2 = -ALOG10(ABS(TEMP))/2.E0 GO TO 15 C 10 DIGIT2 = -ALOG10(ABS(SRELPR)) C 15 IF ((IDGTS .LT. 1) .OR. (LEVEL .LE. 0)) GO TO 20 WRITE(NOUT,40) DIGIT1,DIGIT2 40 FORMAT(/6X,41HAPPROX. NO. OF DIGITS (EST. REL. ERROR) =, A F5.1,2X,8H(DIGIT1) B /3X,44HAPPROX. NO. OF DIGITS (EST. REL. RESIDUAL) =, C F5.1,2X,8H(DIGIT2)) C IF (IDGTS .LE. 1 .OR. IDGTS .GT. 4) GO TO 20 IF (IDGTS .NE. 3) CALL VOUT(N,U,2,NOUT) IF (IDGTS .GE. 3) CALL VOUT(N,W,1,NOUT) C 20 CONTINUE DIGTT1 = DIGIT1 DIGTT2 = DIGIT2 RETURN END SUBROUTINE PERVEC(N,V,P) PERV0010 C C THIS SUBROUTINE PERMUTES A REAL VECTOR AS DICTATED BY THE C PERMUTATION VECTOR, P. IF P(I) = J, THEN V(J) GETS V(I). C C ... PARAMETER LIST: C C V REAL VECTOR OF LENGTH N C P INTEGER PERMUTATION VECTOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N, P(N) REAL V(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER II, NEXT, NOW REAL SAVE, TEMP C IF (N .LE. 0) RETURN C DO 20 II = 1,N IF (P(II) .LT. 0) GO TO 20 C NEXT = P(II) SAVE = V(II) C 10 CONTINUE IF (P(NEXT) .LT. 0) GO TO 20 TEMP = SAVE SAVE = V(NEXT) V(NEXT) = TEMP C NOW = NEXT NEXT = P(NOW) P(NOW) = -NEXT GO TO 10 C 20 CONTINUE C DO 30 II = 1,N P(II) = - P(II) 30 CONTINUE C RETURN END SUBROUTINE PFSOR (NN,IA,JA,A,U,RHS) PFSO0010 C C THIS SUBROUTINE COMPUTES A FORWARD SOR SWEEP. C C ... PARAMETER LIST: C C N ORDER OF SYSTEM (= NN) C OMEGA RELAXATION FACTOR C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C U LATEST ESTIMATE OF SOLUTION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), U(NN), RHS(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, IEND, II, JAJJ, JJ, N REAL OMM1, SUM, UI C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C N = NN OMM1 = OMEGA-1.E0 IF (ISYM.EQ.0) GO TO 40 C C *********** NON - SYMMETRIC SECTION ********************* C DO 30 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 20 DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 10 CONTINUE 20 UI = OMEGA*SUM-OMM1*U(II) U(II) = UI 30 CONTINUE RETURN C C ************* SYMMETRIC SECTION ************************* C 40 DO 80 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 60 DO 50 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 50 CONTINUE 60 UI = OMEGA*SUM-OMM1*U(II) U(II) = UI IF (IBGN.GT.IEND) GO TO 80 DO 70 JJ = IBGN,IEND JAJJ = JA(JJ) RHS(JAJJ) = RHS(JAJJ)-A(JJ)*UI 70 CONTINUE 80 CONTINUE RETURN C END SUBROUTINE PFSOR1 (NN,IA,JA,A,U,RHS) PFSO0010 C C THIS SUBROUTINE COMPUTES A FORWARD SOR SWEEP ON U AND C COMPUTES THE NORM OF THE PSEUDO-RESIDUAL VECTOR. C C ... PARAMETER LIST: C C N ORDER OF SYSTEM (= NN) C OMEGA RELAXATION FACTOR C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C U LATEST ESTIMATE OF SOLUTION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), U(NN), RHS(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, IEND, II, JAJJ, JJ, N REAL OMM1, SUM, SUMD, UI C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C N = NN OMM1 = OMEGA-1.E0 SUMD = 0.E0 IF (ISYM.EQ.0) GO TO 40 C C **************** NON - SYMMETRIC SECTION ****************** C DO 30 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 20 DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 10 CONTINUE 20 CONTINUE UI = OMEGA*SUM-OMM1*U(II) SUMD = SUMD+(UI-U(II))**2 U(II) = UI 30 CONTINUE GO TO 90 C C *************** SYMMETRIC SECTION ************************ C 40 DO 80 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 60 DO 50 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 50 CONTINUE 60 CONTINUE UI = OMEGA*SUM-OMM1*U(II) SUMD = SUMD+(UI-U(II))**2 U(II) = UI IF (IBGN.GT.IEND) GO TO 80 DO 70 JJ = IBGN,IEND JAJJ = JA(JJ) RHS(JAJJ) = RHS(JAJJ)-A(JJ)*UI 70 CONTINUE 80 CONTINUE C 90 DELNNM = SQRT(SUMD) RETURN C END SUBROUTINE PJAC (NN,IA,JA,A,U,RHS) PJAC0010 C C ... THIS SUBROUTINE PERFORMS ONE JACOBI ITERATION. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX (= NN) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C U ESTIMATE OF SOLUTION OF A MATRIX PROBLEM C RHS ON INPUT: CONTAINS THE RIGHT HAND SIDE OF C A MATRIX PROBLEM C ON OUTPUT: CONTAINS A*U + RHS C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), U(NN), RHS(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, IEND, II, JAJJ, JJ, N REAL RHSII, UII C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C N = NN IF (ISYM.EQ.0) GO TO 30 C C *************** NON - SYMMETRIC SECTION **************** C DO 20 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 IF (IBGN.GT.IEND) GO TO 20 RHSII = RHS(II) DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) RHSII = RHSII-A(JJ)*U(JAJJ) 10 CONTINUE RHS(II) = RHSII 20 CONTINUE RETURN C C ************** SYMMETRIC SECTION ********************** C 30 DO 50 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 IF (IBGN.GT.IEND) GO TO 50 RHSII = RHS(II) UII = U(II) DO 40 JJ = IBGN,IEND JAJJ = JA(JJ) RHSII = RHSII-A(JJ)*U(JAJJ) RHS(JAJJ) = RHS(JAJJ)-A(JJ)*UII 40 CONTINUE RHS(II) = RHSII 50 CONTINUE RETURN C END SUBROUTINE PMULT (NN,IA,JA,A,U,W) PMUL0010 C C ... THIS SUBROUTINE PERFORMS ONE MATRIX-VECTOR MULTIPLICATION. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX (= NN) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C U LATEST ESTIMATE OF SOLUTION C W ON RETURN W CONTAINS A*U C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), U(NN), W(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, IEND, II, JJ, N REAL SUM, UII, WII C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C N = NN IF (N.LE.0) RETURN IF (ISYM.EQ.0) GO TO 40 C C *************** NON - SYMMETRIC SECTION ********************** C DO 30 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 SUM = 0.0 IF (IBGN.GT.IEND) GO TO 20 DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM+A(JJ)*U(JAJJ) 10 CONTINUE 20 W(II) = SUM 30 CONTINUE RETURN C C ***************** SYMMETRIC SECTION ************************** C 40 CALL VFILL (N,W,0.E0) DO 70 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 UII = U(II) WII = W(II) IF (IBGN.GT.IEND) GO TO 60 DO 50 JJ = IBGN,IEND JAJJ = JA(JJ) WII = WII+A(JJ)*U(JAJJ) W(JAJJ) = W(JAJJ)+A(JJ)*UII 50 CONTINUE 60 W(II) = WII 70 CONTINUE RETURN C END SUBROUTINE PRBNDX(NN, NBLACK, IA, JA, P, IP, LEVEL, NOUT, IER) PRBN0010 C C************************************************************** C C THIS SUBROUTINE COMPUTES THE RED-BLACK PERMUTATION C VECTORS P ( AND ITS INVERSE IP ) IF POSSIBLE. C C THE ALGORITHM IS TO MARK THE FIRST NODE AS RED (ARBITRARY). C ALL OF ITS ADJACENT NODES ARE MARKED BLACK AND PLACED IN C A STACK. THE REMAINDER OF THE CODE PULLS THE FIRST NODE C OFF THE TOP OF THE STACK AND TRIES TO TYPE ITS ADJACENT NODES. C THE TYPING OF THE ADJACENT POINT IS A FIVE WAY CASE STATEMENT C WHICH IS WELL COMMENTED BELOW (SEE DO LOOP 100). C C THE ARRAY P IS USED BOTH TO KEEP TRACK OF THE COLOR OF A NODE C (RED NODE IS POSITIVE, BLACK IS NEGATIVE) BUT ALSO THE FATHER C NODE THAT CAUSED THE COLOR MARKING OF THAT POINT. SINCE C COMPLETE INFORMATION ON THE ADJACENCY STRUCTURE IS HARD TO COME C BY THIS FORMS A LINK TO ENABLE THE COLOR CHANGE OF A PARTIAL C TREE WHEN A RECOVERABLE COLOR CONFLICT OCCURS. C C THE ARRAY IP IS USED AS A STACK TO POINT TO THE SET OF NODES C LEFT TO BE TYPED THAT ARE KNOWN TO BE ADJACENT TO THE CURRENT C FATHER NODE. C C********************************************************************* C C INPUT PARAMETERS C C N NUMBER OF NODES. (INTEGER, SCALAR) (= NN) C C IA,JA ADJACENCY STRUCTURE ARRAYS. CAN BE EITHER THE C SYMMETRIC OR NONSYMMETRIC FORM. IT IS ASSUMED C THAT FOR EVERY ROW WHERE ONLY ONE ELEMENT IS C STORED THAT ELEMENT CORRESPONDS TO THE DIAGONAL C ENTRY. THE DIAGONAL DOES NOT HAVE TO BE THE FIRST C ENTRY STORED. (INTEGER, ARRAYS) C LEVEL SWITCH FOR PRINTING C NOUT OUTPUT TAPE NUMBER C C OUTPUT PARAMETERS C C NBLACK NUMBER OF BLACK NODES. NUMBER OF RED NODES IS C N - NBLACK. (INTEGER, SCALAR) C C P, IP PERMUTATION AND INVERSE PERMUTATION VECTORS. C (INTEGER, ARRAYS EACH OF LENGTH N) C C IER ERROR FLAG. (INTEGER, SCALAR) C C IER = 0, NORMAL RETURN. INDEXING PERFORMED C SUCCESSFULLY C IER =201, RED-BLACK INDEXING NOT POSSIBLE. C C******************************************************************** C INTEGER NN, NBLACK, IA(1), JA(1), P(NN), IP(NN), IER C INTEGER FIRST, NEXT, LAST, I, OLD, YOUNG, IBGN, IEND, J, K, A CURTYP, NXTTYP, TYPE, NRED, N C C----------------------------------------------------------------------- C N = NN IER = 0 C IF ( N .LE. 0 ) GO TO 8000 DO 10 I = 1, N P(I) = 0 IP(I) = 0 10 CONTINUE C C ... HANDLE THE FIRST SET OF POINTS UNTIL SOME ADJACENT POINTS C ... ARE FOUND C FIRST = 1 C 20 P(FIRST) = FIRST IF ( IA(FIRST+1)-IA(FIRST) .GT. 1 ) GO TO 30 C C ... SEARCH FOR NEXT ENTRY THAT HAS NOT BEEN MARKED C IF ( FIRST .EQ. N ) GO TO 200 IBGN = FIRST + 1 DO 25 I = IBGN, N IF ( P(I) .NE. 0 ) GO TO 25 FIRST = I GO TO 20 25 CONTINUE GO TO 200 C C ... FIRST SET OF ADJACENT POINTS FOUND C 30 NEXT = 1 LAST = 1 IP(1) = FIRST C C ... LOOP OVER LABELED POINTS INDICATED IN THE STACK STORED IN C ... THE ARRAY IP C 50 K = IP(NEXT) CURTYP = P(K) NXTTYP = -CURTYP IBGN = IA(K) IEND = IA(K+1) - 1 IF ( IBGN .GT. IEND ) GO TO 110 DO 100 I = IBGN, IEND J = JA(I) TYPE = P(J) IF ( J .EQ. K ) GO TO 100 C C================================================================== C C THE FOLLOWING IS A FIVE WAY CASE STATEMENT DEALING WITH THE C LABELING OF THE ADJACENT NODE. C C ... CASE I. IF THE ADJACENT NODE HAS ALREADY BEEN LABELED WITH C LABEL EQUAL TO NXTTYP, THEN SKIP TO THE NEXT ADJACENT C NODE. C IF ( TYPE .EQ. NXTTYP ) GO TO 100 C C ... CASE II. IF THE ADJACENT NODE HAS NOT BEEN LABELED YET LABEL C IT WITH NXTTYP AND ENTER IT IN THE STACK C IF ( TYPE .NE. 0 ) GO TO 60 LAST = LAST + 1 IP(LAST) = J P(J) = NXTTYP GO TO 100 C C ... CASE III. IF THE ADJACENT NODE HAS ALREADY BEEN LABELED WITH C OPPOSITE COLOR AND THE SAME FATHER SEED, THEN THERE C IS AN IRRECOVERABLE COLOR CONFLICT. C 60 IF ( TYPE .EQ. CURTYP ) GO TO 8010 C C ... CASE IV. IF THE ADJACENT NODE HAS THE RIGHT COLOR AND A DIFFERENT C FATHER NODE, THEN CHANGE ALL NODES OF THE YOUNGEST FATHE C NODE TO POINT TO THE OLDEST FATHER SEED AND RETAIN THE C SAME COLORS. C IF ( TYPE * NXTTYP .LT. 1 ) GO TO 80 OLD = MIN0 ( IABS(TYPE), IABS(NXTTYP) ) YOUNG = MAX0 ( IABS(TYPE), IABS(NXTTYP) ) DO 70 J = YOUNG, N IF ( IABS(P(J)) .EQ. YOUNG ) P(J) = ISIGN ( OLD, P(J) ) 70 CONTINUE CURTYP = P(K) NXTTYP = -CURTYP GO TO 100 C C ... CASE V. IF THE ADJACENT NODE HAS THE WRONG COLOR AND A DIFFERENT C FATHER NODE, THEN CHANGE ALL NODES OF THE YOUNGEST FATHER C NODE TO POINT TO THE OLDEST FATHER NODE ALONG WITH C CHANGING THEIR COLORS. SINCE UNTIL THIS TIME THE C YOUNGEST FATHER NODE TREE HAS BEEN INDEPENDENT NO OTHER C COLOR CONFLICTS WILL ARISE FROM THIS CHANGE. C 80 OLD = MIN0 ( IABS(TYPE), IABS(NXTTYP) ) YOUNG = MAX0 ( IABS(TYPE), IABS(NXTTYP) ) DO 90 J = YOUNG, N IF ( IABS(P(J)) .EQ. YOUNG ) P(J) = ISIGN( OLD, -P(J) ) 90 CONTINUE CURTYP = P(K) NXTTYP = -CURTYP C C C ... END OF CASE STATEMENT C C================================================================== 100 CONTINUE C C ... ADVANCE TO NEXT NODE IN THE STACK C 110 NEXT = NEXT + 1 IF ( NEXT .LE. LAST ) GO TO 50 C C ... ALL NODES IN THE STACK HAVE BEEN REMOVED C C ... CHECK FOR NODES NOT LABELED. IF ANY ARE FOUND C ... START THE LABELING PROCESS AGAIN AT THE FIRST C ... NODE FOUND THAT IS NOT LABELED. C IBGN = FIRST + 1 DO 120 I = IBGN, N IF ( P(I) .NE. 0 ) GO TO 120 FIRST = I GO TO 20 120 CONTINUE C C C=================================================================== C C C ... ALL NODES ARE NOW TYPED EITHER RED OR BLACK C C C ... GENERATE PERMUTATION VECTORS C 200 NRED = 0 NBLACK = 0 DO 220 I = 1, N IF ( P(I) .LT. 0 ) GO TO 210 C C RED POINT C NRED = NRED + 1 IP(NRED) = I P(I) = NRED GO TO 220 C C BLACK POINT C 210 NBLACK = NBLACK + 1 J = N - NBLACK + 1 IP(J) = I P(I) = J C 220 CONTINUE C C ... SUCCESSFUL RED-BLACK ORDERING COMPLETED C GO TO 9000 C C C ........ ERROR TRAPS C C ...... N .LE. 0 C C8000 IER = 200 C GO TO 9000 C C ...... TYPE CONFLICT C 8010 IER = 201 IF(LEVEL .GE. 0) WRITE(NOUT,8015) 8015 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE PRBNDX B / 1H , 35H RED-BLACK INDEXING NOT POSSIBLE ) C C ... RETURN C 9000 CONTINUE RETURN END SUBROUTINE PRSBLK(NNB,NNR,IA,JA,A,UR,VB) PRSB0010 C C ... COMPUTE A BLACK-RS SWEEP ON A RED VECTOR INTO A BLACK VECTOR C C ... PARAMETER LIST: C C NB NUMBER OF BLACK POINTS (= NNB) C NR NUMBER OF RED POINTS (= NNR) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C UR ESTIMATE OF RED SOLUTION VECTOR C VB OUTPUT: PRESENT ESTIMATE OF BLACK SOLUTION C VECTOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NNB, NNR REAL A(1), UR(NNR), VB(NNB) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, IBGN, IEND, INR, J, JAJ, NB, NR REAL SUM, URI C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C NB = NNB NR = NNR IF (ISYM .EQ. 0) GO TO 30 C C *************** NON - SYMMETRIC SECTION ********************** C DO 20 I = 1,NB INR = I + NR IBGN = IA(INR) IEND = IA(INR+1) - 1 SUM = VB(I) IF (IBGN .GT. IEND) GO TO 20 DO 10 J = IBGN,IEND JAJ = JA(J) SUM = SUM - A(J) * UR(JAJ) 10 CONTINUE VB(I) = SUM 20 CONTINUE RETURN C C ***************** SYMMETRIC SECTION ************************** C 30 DO 50 I = 1,NR IBGN = IA(I) IEND = IA(I+1) - 1 IF (IBGN .GT. IEND) GO TO 50 URI = UR(I) DO 40 J = IBGN,IEND JAJ = JA(J) - NR VB(JAJ) = VB(JAJ) - A(J) * URI 40 CONTINUE 50 CONTINUE C RETURN END SUBROUTINE PRSRED(NNB,NNR,IA,JA,A,UB,VR) PRSR0010 C C ... COMPUTES A RED-RS SWEEP ON A BLACK VECTOR INTO A RED VECTOR. C C ... PARAMETER LIST: C C NB NUMBER OF BLACK POINTS (= NNR) C NR NUMBER OF RED POINTS (= NNB) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C UB PRESENT ESTIMATE OF BLACK SOLUTION VECTOR C VR OUTPUT: PRESENT ESTIMATE OF RED SOLUTION VECTOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NNB, NNR REAL A(1), UB(NNB), VR(NNR) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, IEND, II, JAJJ, JJ, NB, NR REAL SUM C NB = NNB NR = NNR DO 20 II = 1,NR IBGN = IA(II) IEND = IA(II+1) - 1 IF (IBGN.GT.IEND) GO TO 20 SUM = VR(II) DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) - NR SUM = SUM - A(JJ) * UB(JAJJ) 10 CONTINUE VR(II) = SUM 20 CONTINUE C RETURN END SUBROUTINE PSSOR1 (NN,IA,JA,A,U,RHS,FR,BR) PSSO0010 C C ... COMPUTES COMPLETE SSOR SWEEP ON U. U IS OVERWRITTEN C ... WITH THE NEW ITERANT, FR AND BR WILL CONTAIN C ... THE FORWARD AND BACKWARD RESIDUALS ON OUTPUT. C C ... PARAMETER LIST: C C N ORDER OF SYSTEM (= NN) C OMEGA RELAXATION FACTOR C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C U ESTIMATE OF SOLUTION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C FR,BR OUTPUT: FORWARD AND BACKWARD RESIDUALS RESPECTIVELY C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN REAL A(1), U(NN), RHS(NN), FR(NN), BR(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, IBGN, IEND, II, JAJJ, JJ, N, NPL1 REAL OMM1, SUM, UII C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C N = NN NPL1 = N+1 OMM1 = OMEGA-1.E0 IF (ISYM.EQ.0) GO TO 40 C C *************** NON - SYMMETRIC SECTION ********************** C C C ... FORWARD SWEEP C DO 30 II = 1,N BR(II) = U(II) IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 20 DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 10 CONTINUE 20 UII = OMEGA*SUM-OMM1*U(II) FR(II) = UII-U(II) U(II) = UII 30 CONTINUE GO TO 90 C C ***************** SYMMETRIC SECTION ************************** C C ... FORWARD SWEEP C 40 DO 80 II = 1,N BR(II) = U(II) IBGN = IA(II) IEND = IA(II+1)-1 SUM = RHS(II) IF (IBGN.GT.IEND) GO TO 60 DO 50 JJ = IBGN,IEND JAJJ = JA(JJ) SUM = SUM-A(JJ)*U(JAJJ) 50 CONTINUE 60 UII = OMEGA*SUM-OMM1*U(II) FR(II) = UII-U(II) U(II) = UII IF (IBGN.GT.IEND) GO TO 80 DO 70 JJ = IBGN,IEND JAJJ = JA(JJ) RHS(JAJJ) = RHS(JAJJ)-A(JJ)*UII 70 CONTINUE 80 CONTINUE C C ... BACKWARD SWEEP C 90 DO 120 I = 1,N II = NPL1-I IBGN = IA(II) IEND = IA(II+1)-1 UII = RHS(II) IF (IBGN.GT.IEND) GO TO 110 DO 100 JJ = IBGN,IEND JAJJ = JA(JJ) UII = UII-A(JJ)*U(JAJJ) 100 CONTINUE 110 U(II) = OMEGA*UII-OMM1*U(II) BR(II) = U(II)-BR(II) 120 CONTINUE C RETURN C END SUBROUTINE PSTOP(N,U,DNRM,CCON,IFLAG,Q1) PSTO0010 C C THIS SUBROUTINE PERFORMS A TEST TO SEE IF THE ITERATIVE C METHOD HAS CONVERGED TO A SOLUTION INSIDE THE ERROR C TOLERANCE, ZETA. C C ... PARAMETER LIST: C C N ORDER OF SYSTEM C U PRESENT SOLUTION ESTIMATE C DNRM INNER PRODUCT OF PSEUDO-RESIDUALS AT PRECEDING C ITERATION C CON STOPPING TEST PARAMETER (= CCON) C IFLAG STOPPING TEST INTEGER FLAG C IFLAG = 0, SOR ITERATION ZERO C IFLAG = 1, NON-RS METHOD C IFLAG = 2, RS METHOD C Q1 STOPPING TEST LOGICAL FLAG C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N, IFLAG REAL U(N), A DNRM, CCON LOGICAL Q1 C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL CON, TL, TR, UOLD C C ... SPECIFICATIONS FOR ARGUMENT SUBROUTINES C REAL SDOT C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C C CON = CCON HALT = .FALSE. C C SPECIAL PROCEDURE FOR ZEROTH ITERATION C IF (IN .GE. 1) GO TO 10 Q1 = .FALSE. UDNM = 1.E0 STPTST = 1.E3 IF (IFLAG .LE. 0) RETURN C C ... TEST IF UDNM NEEDS TO BE RECOMPUTED C 10 CONTINUE IF (Q1) GO TO 20 IF ((IN.GT.5) .AND. (MOD(IN,5).NE.0)) GO TO 20 UOLD = UDNM UDNM = SDOT(N,U,1,U,1) IF(UDNM .EQ. 0.E0) UDNM = 1.E0 IF ((IN .GT. 5) .AND. A (ABS(UDNM-UOLD) .LE. UDNM*ZETA)) Q1 = .TRUE. C C ... COMPUTE STOPPING TEST C 20 TR = SQRT(UDNM) TL = 1.E0 IF(CON .EQ. 1.E0) GO TO 30 IF(IFLAG .EQ. 2) GO TO 25 TL = SQRT(DNRM) TR = TR*(1.E0 - CON) GO TO 30 25 TL = SQRT(2.E0*DNRM) TR = TR*(1.E0 - CON*CON) 30 STPTST = TL/TR IF(TL .GE. TR*ZETA) RETURN HALT = .TRUE. C RETURN END REAL FUNCTION PVTBV (N,IA,JA,A,V) PVTB0010 C C THIS FUNCTION COMPUTES (V**T)*A*V. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C V REAL VECTOR OF LENGTH N C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A N REAL A(1), V(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, IEND, II, JAJJ, JJ REAL SUM, SUMR C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C PVTBV = 0.E0 SUM = 0.E0 DO 20 II = 1,N IBGN = IA(II) IEND = IA(II+1)-1 IF (IBGN.GT.IEND) GO TO 20 SUMR = 0.E0 DO 10 JJ = IBGN,IEND JAJJ = JA(JJ) SUMR = SUMR-A(JJ)*V(JAJJ) 10 CONTINUE SUM = SUM+V(II)*SUMR 20 CONTINUE C IF(ISYM .EQ. 0) SUM = 2.E0*SUM PVTBV = SUM C RETURN END SUBROUTINE QSORT (NN, KEY, DATA, ERROR) QSOR0010 C C ================================================================== C C Q U I C K S O R T C C IN THE STYLE OF THE CACM PAPER BY BOB SEDGEWICK, OCTOBER 1978 C C INPUT: C N -- NUMBER OF ELEMENTS TO BE SORTED (= NN) C KEY -- AN ARRAY OF LENGTH N CONTAINING THE VALUES C WHICH ARE TO BE SORTED C DATA -- A SECOND ARRAY OF LENGTH N CONTAINING DATA C ASSOCIATED WITH THE INDIVIDUAL KEYS. C C OUTPUT: C KEY -- WILL BE ARRANGED SO THAT VALUES ARE IN INCREASING C ORDER C DATA -- REARRANGED TO CORRESPOND TO REARRANGED KEYS C ERROR -- WILL BE ZERO UNLESS YOUR INPUT FILE WAS OF TRULY C ENORMOUS LENGTH, IN WHICH CASE IT WILL BE EQUAL TO 1. C C C ================================================================== C INTEGER NN, ERROR, KEY(NN) REAL DATA(NN) C C ------------------------ C INTEGER TOP, LEFT, RIGHT, I, J, TINY, V, K, IP1, JM1, 1 LLEN, RLEN, N LOGICAL DONE REAL D INTEGER STKLEN, STACK(30) C DATA TINY, STKLEN / 9, 30 / C C ----------------------------------- C C ... PROGRAM IS A DIRECT TRANSLATION INTO FORTRAN OF SEDGEWICK S C PROGRAM 2, WHICH IS NON-RECURSIVE, IGNORES FILES OF LENGTH C LESS THAN 'TINY' DURING PARTITIONING, AND USES MEDIAN OF THREE C PARTITIONING. C N = NN IF (N .EQ. 1) RETURN IF (N .LE. 0) GO TO 6000 C ERROR = 0 TOP = 1 LEFT = 1 RIGHT = N DONE = (N .LE. TINY) C IF(DONE) GO TO 2000 CALL IVFILL(STKLEN,STACK,0) C C =========================================================== C QUICKSORT -- PARTITION THE FILE UNTIL NO SUBFILE REMAINS OF C LENGTH GREATER THAN 'TINY' C =========================================================== C C ... WHILE NOT DONE DO ... C 100 IF (DONE) GO TO 2000 C C ... FIND MEDIAN OF LEFT, RIGHT AND MIDDLE ELEMENTS OF CURRENT C SUBFILE, WHICH IS KEY(LEFT), ..., KEY(RIGHT) C LFRH2 = (LEFT + RIGHT)/2 K = KEY (LFRH2) D = DATA (LFRH2) KEY (LFRH2) = KEY (LEFT) DATA (LFRH2) = DATA (LEFT) KEY (LEFT) = K DATA (LEFT) = D C IF ( KEY(LEFT+1) .LE. KEY(RIGHT) ) GO TO 200 K = KEY (LEFT+1) D = DATA (LEFT+1) KEY (LEFT+1) = KEY (RIGHT) DATA (LEFT+1) = DATA (RIGHT) KEY (RIGHT) = K DATA (RIGHT) = D C 200 IF ( KEY(LEFT) .LE. KEY(RIGHT) ) GO TO 300 K = KEY (LEFT) D = DATA (LEFT) KEY (LEFT) = KEY (RIGHT) DATA (LEFT) = DATA (RIGHT) KEY (RIGHT) = K DATA (RIGHT) = D C 300 IF ( KEY (LEFT+1) .LE. KEY (LEFT) ) GO TO 400 K = KEY (LEFT+1) D = DATA (LEFT+1) KEY (LEFT+1) = KEY (LEFT) DATA (LEFT+1) = DATA (LEFT) KEY (LEFT) = K DATA (LEFT) = D C 400 V = KEY (LEFT) C C ... V IS NOW THE MEDIAN VALUE OF THE THREE KEYS. NOW MOVE C FROM THE LEFT AND RIGHT ENDS SIMULTANEOUSLY, EXCHANGING C KEYS AND DATA UNTIL ALL KEYS LESS THAN V ARE PACKED TO C THE LEFT, ALL KEYS LARGER THAN V ARE PACKED TO THE C RIGHT. C I = LEFT+1 J = RIGHT C C LOOP C REPEAT I = I+1 UNTIL KEY(I) >= V; C REPEAT J = J-1 UNTIL KEY(J) <= V; C EXIT IF J < I; C << EXCHANGE KEYS I AND J >> C END C 500 CONTINUE 600 I = I + 1 IF ( KEY(I) .LT. V ) GO TO 600 C 700 J = J - 1 IF ( KEY(J) .GT. V ) GO TO 700 C IF (J .LT. I) GO TO 800 K = KEY (I) D = DATA (I) KEY (I) = KEY (J) DATA (I) = DATA (J) KEY (J) = K DATA (J) = D GO TO 500 C 800 K = KEY (LEFT) D = DATA (LEFT) KEY (LEFT) = KEY (J) DATA (LEFT) = DATA (J) KEY (J) = K DATA (J) = D C C C ... WE HAVE NOW PARTITIONED THE FILE INTO TWO SUBFILES, C ONE IS (LEFT ... J-1) AND THE OTHER IS (I...RIGHT). C PROCESS THE SMALLER NEXT. STACK THE LARGER ONE. C LLEN = J-LEFT RLEN = RIGHT - I + 1 IF ( MAX0 (LLEN, RLEN) .GT. TINY ) GO TO 1100 C C ... BOTH SUBFILES ARE TINY, SO UNSTACK NEXT LARGER FILE C IF (TOP .EQ. 1) GO TO 900 TOP = TOP - 2 LEFT = STACK (TOP) RIGHT = STACK (TOP+1) GO TO 100 C 900 DONE = .TRUE. C GO TO 100 C C ... ELSE ONE OR BOTH SUBFILES ARE LARGE C 1100 IF (MIN0 (LLEN, RLEN) .GT. TINY) GO TO 1400 C C ... ONE SUBFILE IS SMALL, ONE LARGE. IGNORE THE SMALL ONE C IF ( LLEN .GT. RLEN ) GO TO 1200 LEFT = I GO TO 100 C 1200 RIGHT = J - 1 C GO TO 100 C C ... ELSE BOTH ARE LARGER THAN TINY. ONE MUST BE STACKED. C 1400 IF ( TOP .GE. STKLEN ) GO TO 6000 IF ( LLEN .GT. RLEN ) GO TO 1500 STACK (TOP) = I STACK (TOP+1) = RIGHT RIGHT = J-1 GO TO 1600 C 1500 STACK (TOP) = LEFT STACK (TOP+1) = J-1 LEFT = I C 1600 TOP = TOP + 2 C GO TO 100 C C ------------------------------------------------------------ C INSERTION SORT THE ENTIRE FILE, WHICH CONSISTS OF A LIST C OF 'TINY' SUBFILES, LOCALLY OUT OF ORDER, GLOBALLY IN ORDER. C ------------------------------------------------------------ C C ... FIRST, FIND LARGEST ELEMENT IN 'KEY' C 2000 I = N - 1 LEFT = MAX0 (0, N - TINY) K = KEY (N) J = N C 2100 IF ( I .LE. LEFT ) GO TO 2300 IF ( KEY(I) .LE. K ) GO TO 2200 K = KEY(I) J = I C 2200 I = I - 1 GO TO 2100 C 2300 IF ( J .EQ. N ) GO TO 2400 C C ... LARGEST ELEMENT WILL BE IN KEY(N) C KEY(J) = KEY(N) KEY(N) = K D = DATA(N) DATA(N) = DATA(J) DATA(J) = D C C ... INSERTION SORT ... FOR I := N-1 STEP -1 TO 1 DO ... C 2400 I = N - 1 IP1 = N C 2500 IF ( KEY (I) .LE. KEY (IP1) ) GO TO 2800 C C ... OUT OF ORDER ... MOVE UP TO CORRECT PLACE C K = KEY (I) D = DATA (I) J = IP1 JM1 = I C C ... REPEAT ... UNTIL 'CORRECT PLACE FOR K FOUND' C 2600 KEY (JM1) = KEY (J) DATA (JM1) = DATA (J) JM1 = J J = J + 1 IF (KEY (J) .LT. K) GO TO 2600 C KEY (JM1) = K DATA (JM1) = D C 2800 IP1 = I I = I - 1 IF ( I .GT. 0 ) GO TO 2500 C 3000 RETURN C 6000 ERROR = 1 GO TO 3000 C END SUBROUTINE SAXPY (NN,SAA,SX,INCXX,SY,INCYY) SAXP0010 C C PURPOSE - COMPUTE A CONSTANT TIMES A VECTOR PLUS C A VECTOR, ALL SINGLE PRECISION C C USAGE - CALL SAXPY (N,SA,SX,INCX,SY,INCY) C C ARGUMENTS N - LENGTH OF VECTORS SX AND SY. (INPUT) (= NN) C SA - REAL SCALAR. (INPUT) (= SAA) C SX - REAL VECTOR OF LENGTH MAX(N*IABS(INCX),1). C (INPUT) C INCX - DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT) C (= INCXX) C X(I) IS DEFINED TO BE.. C SX(1+(I-1)*INCX) IF INCX.GE.0 OR C SX(1+(I-N)*INCX) IF INCX.LT.0. C SY - REAL VECTOR OF LENGTH MAX(N*IABS(INCY),1). C (INPUT/OUTPUT) C SAXPY REPLACES Y(I) WITH SA*X(I)+Y(I) C FOR I=1,...,N. C X(I) AND Y(I) REFER TO SPECIFIC ELEMENTS C OF SX AND SY, RESPECTIVELY. SEE INCX AND C INCY ARGUMENT DESCRIPTIONS. C INCY - DISPLACEMENT BETWEEN ELEMENTS OF SY. (INPUT) C (= INCYY) C Y(I) IS DEFINED TO BE.. C SY(1+(I-1)*INCY) IF INCY.GE.0 OR C SY(1+(I-N)*INCY) IF INCY.LT.0. C C SPECIFICATIONS FOR ARGUMENTS INTEGER NN,INCXX,INCYY REAL SX(NN),SY(NN),SAA C SPECIFICATIONS FOR LOCAL VARIABLES REAL SA INTEGER I,IX,IY,M,MP1,NS,INCX,INCY,N C FIRST EXECUTABLE STATEMENT N = NN SA = SAA INCX = INCXX INCY = INCYY IF (N.LE.0.OR.SA.EQ.0.E0) RETURN IF (INCX.EQ.INCY) IF (INCX-1) 5,15,35 5 CONTINUE C CODE FOR NONEQUAL OR NONPOSITIVE C INCREMENTS. 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 C CODE FOR BOTH INCREMENTS EQUAL TO 1 C CLEAN-UP LOOP SO REMAINING VECTOR C LENGTH IS A MULTIPLE OF 4. 15 M = N-(N/4)*4 IF (M.EQ.0) GO TO 25 DO 20 I=1,M SY(I) = SY(I)+SA*SX(I) 20 CONTINUE IF (N.LT.4) RETURN 25 MP1 = M+1 DO 30 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) 30 CONTINUE RETURN C CODE FOR EQUAL, POSITIVE, NONUNIT C INCREMENTS. 35 CONTINUE NS = N*INCX DO 40 I=1,NS,INCX SY(I) = SA*SX(I)+SY(I) 40 CONTINUE RETURN END SUBROUTINE SBAGN (N,NZ,IA,JA,A,IWORK,LEVELL,NOUTT,IERR) SBAG0010 C C ... THE ROUTINES SBINI, SBSIJ, AND SBEND CREATE A SPARSE C MATRIX STRUCTURE BY MEANS OF A LINKED LIST WHICH IS C DESTROYED BY SBEND. SBAGN CREATES A NEW LINKED LIST C SO THAT ELEMENTS MAY BE ADDED TO THE MATRIX AFTER SBEND C HAS BEEN CALLED. SBAGN SHOULD BE CALLED WITH THE APPRO- C PRIATE PARAMETERS, AND THEN SBSIJ AND SBEND CAN BE CALLED C TO ADD THE ELEMENTS AND COMPLETE THE SPARSE MATRIX STRUC- C TURE. C C ... PARAMETER LIST: C C N ORDER OF THE SYSTEM C NZ MAXIMUM NUMBER OF NON-ZERO ELEMENTS C IN THE SYSTEM C IA, JA INTEGER ARRAYS OF THE SPARSE C MATRIX STRUCTURE C A REAL ARRAY OF THE SPARSE MATRIX C STRUCTURE C IWORK WORK ARRAY OF DIMENSION NZ C LEVEL OUTPUT LEVEL CONTROL (= LEVELL) C NOUT OUTPUT FILE NUMBER (= NOUTT) C IER ERROR FLAG (= IERR). POSSIBLE RETURNS ARE C IER = 0, SUCCESSFUL COMPLETION C = 703, NZ TOO SMALL - NO MORE C ELEMENTS CAN BE ADDED C C ... SPECIFICTIONS FOR ARGUMENTS C INTEGER NZ, IA(1), JA(1), IWORK(NZ), A N, LEVELL, NOUTT, IERR REAL A(NZ) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, IER, J, LEVEL, NOUT, NADD, NADDP1, NOW, NP1, A NTO, NTN C C ... INITIALIZE LOCAL VARIABLES AND MAKE ERROR CHECK C NOW = IA(N+1) - 1 NADD = NZ - NOW IER = 0 LEVEL = LEVELL NOUT = NOUTT IF (NADD .LE. 0) IER = 703 IF (IER .EQ. 0) GO TO 5 IF (LEVEL .GE. 0) WRITE (NOUT,3) IER 3 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SBAGN B / 1H , 10H IER = ,I10 C / 1H , 40H NZ TOO SMALL - NO ROOM FOR NEW ENTRY ) GO TO 60 C C ... SHIFT ELEMENTS OF A AND JA DOWN AND ADD ZERO FILL C 5 NTO = NOW NTN = NZ DO 10 I=1,NOW JA(NTN) = JA(NTO) A(NTN) = A(NTO) NTO = NTO - 1 NTN = NTN - 1 10 CONTINUE DO 20 I=1,NADD JA(I) = 0 A(I) = 0.E0 20 CONTINUE C C ... UPDATE IA TO REFLECT DOWNWARD SHIFT IN A AND JA C NP1 = N + 1 DO 30 I=1,NP1 30 IA(I) = IA(I) + NADD C C ... CREATE LINKED LIST C NADDP1 = NADD + 1 DO 40 I=NADDP1,NZ 40 IWORK(I) = I + 1 DO 45 I=1,NADD 45 IWORK(I) = 0 DO 50 I=1,N J = IA(I+1) - 1 50 IWORK(J) = -I C C ... INDICATE IN LAST POSITION OF IA HOW MANY SPACES C ARE LEFT IN A AND JA FOR ADDITION OF ELEMENTS C IA(N+1) = NADD RETURN C C ... ERROR RETURN C 60 IERR = IER RETURN END SUBROUTINE SBELM(NN,IA,JA,A,RHS,IW,RW,TOL,ISYM,LEVEL,NOUT,IER) SBEL0010 C C ... SBELM IS DESIGNED TO REMOVE ROWS AND COLUMNS OF THE MATRIX C ... WHERE ABS(A(I,J))/A(I,I) .LE. TOL FOR J = 1 TO N AND A(I,I) C ... .GT. 0. THIS IS TO TAKE CARE OF MATRICES ARISING C ... FROM FINITE ELEMENT DISCRETIZATIONS OF PDE S WITH DIRICHLET C ... BOUNDARY CONDITIONS. ANY SUCH ROWS AND CORRESPONDING COLUMNS C ... ARE THEN SET TO THE IDENTITY AFTER CORRECTING RHS. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX (= NN) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C IW,RW WORK ARRAYS OF LENGTH N C TOL TOLERANCE FACTOR C ISYM FLAG FOR TYPE OF STORAGE FOR SYSTEM C (0: SYMMETRIC, 1:NONSYMMETRIC) C LEVEL PRINTING SWITCH FOR ERROR CONDITION C NOUT OUTPUT TAPE NUMBER C IER ERROR FLAG: NONZERO VALUE ON RETURN MEANS C 101 : DIAGONAL ENTRY NOT POSITIVE C 102 : THERE IS NO DIAGONAL ENTRY IN ROW C C********************************************************************** C C UPDATE. SBELM HAS BEEN REWRITTEN TO SPEED UP THE LOCATION OF C OF ROWS WHICH ARE TO BE ELIMINATED. THIS IS DONE BY C FIRST STORING THE LARGEST ELEMENT OF EACH ROW IN C THE ARRAY RW. THE DIAGONAL ENTRY IS THEN COMPARED C WITH THE CORRESPONDING ELEMENT IN RW. IF IT IS C DECIDED TO ELIMINATE THE ROW THEN IT IS MARKED FOR C ELIMINATION. C C WHEN A ROW IS TO BE ELIMINATED ITS DIAGONAL ENTRY C IS STORED IN RW AND IW IS MARKED BY A NONZERO C (WHICH IS THIS ROW NUMBER) C C ROWS WHICH HAVE ONLY DIAGONAL ENTRIES ARE NOT C ALTERED. C C********************************************************************* C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER NN, IA(1), JA(1), IW(NN), A ISYM, LEVEL, NOUT, IER REAL A(1), RHS(NN), RW(NN), A TOL C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, ICNT, IEND, JJ, JJDI, KK, N REAL DI C N = NN C IF (N .GE. 1) GO TO 10 C IER = 100 C RETURN C 10 CONTINUE C C ... STORE THE LARGEST (ABSOLUTE VALUE) OFF DIAGONAL ENTRY FOR C ... ROW II IN RW(II). C IER = 0 ICNT = 0 DO 20 II = 1, N RW(II) = 0.0E0 IW(II) = 0 20 CONTINUE DO 30 II = 1, N IBGN = IA(II) IEND = IA(II+1) - 1 IF ( IBGN .GT. IEND ) GO TO 120 DO 30 JJ = IBGN, IEND KK = JA(JJ) IF ( KK .EQ. II ) GO TO 30 RW(II) = AMAX1 ( RW(II), ABS( A(JJ) ) ) IF(ISYM .NE. 0) GO TO 30 RW(KK) = AMAX1 ( RW(KK), ABS( A(JJ) ) ) 30 CONTINUE C C ... FOR II = 1 TO N FIND THE DIAGONAL ENTRY IN ROW II C DO 60 II = 1,N IBGN = IA(II) IEND = IA(II+1) - 1 DO 40 JJ = IBGN,IEND IF (JA(JJ) .NE. II) GO TO 40 DI = A(JJ) JJDI = JJ IF (DI .GT. 0.E0) GO TO 50 IER = 101 IF(LEVEL .GE. 0) WRITE(NOUT,35) II,DI 35 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SBELM B / 1H , 20H DIAGONAL ELEMENT ,I10,15H NOT POSITIVE C / 1H , 20H CURRENT VALUE = ,E15.8) RETURN 40 CONTINUE GO TO 120 50 CONTINUE C C ... CHECK THE SIZE OF THE LARGEST OFF DIAGONAL ELEMENT C ... ( STORED IN RW(II) ) AGAINST THE DIAGONAL ELEMENT DII. C IF (RW(II) .NE. 0.0E0) GO TO 55 IF (1.0E0 / DI .LE. TOL) GO TO 56 GO TO 60 55 IF (RW(II) / DI .GT. TOL) GO TO 60 C C ... THE OFF DIAGONAL ELEMENTS ARE SMALL COMPARED TO THE DIAGONAL C ... THEREFORE MARK IT FOR ELIMINATION AND PERFORM INITIAL C ... PROCESSING C 56 ICNT = ICNT + 1 IW(II) = II RW(II) = DI A(JJDI) = 1.0E0 RHS(II) = RHS(II) / DI C 60 CONTINUE C C ... ELIMINATE THE ROWS AND COLUMNS INDICATED BY THE NONZERO C ... ENTRIES IN IW. THERE ARE ICNT OF THEM C IF ( ICNT .EQ. 0 ) GO TO 110 C C ... THE ELIMINATION IS AS FOLLOWS: C C FOR II = 1 TO N DO C IF ( IW(II) .NE. 0 ) THEN C SET DIAGONAL VALUE TO 1.0 ( ALREADY DONE ) C SET RHS(II) = RHS(II) / RW(II) ( ALREADY DONE ) C FIND NONZERO OFFDIAGONAL ENTRIES KK C IF ( IW(KK) .EQ. 0 ) FIX UP RHS(KK) WHEN USING SYMMETRIC ST C SET A(II,KK) = 0.0 C ELSE ( I.E. IW(II) .EQ. 0 ) C FIND NONZERO OFFDIAGONAL ENTRIES KK C IF ( IW(KK) .NE. 0 ) FIX UP RHS(II) C AND SET A(II,KK) = 0.0 C END IF C END DO C DO 100 II = 1, N IBGN = IA(II) IEND = IA(II+1) - 1 IF ( IW(II) .EQ. 0 ) GO TO 80 C C ... THE II-TH ROW IS TO BE ELIMINATED C DO 70 JJ = IBGN, IEND KK = JA(JJ) IF ( KK .EQ. II ) GO TO 70 IF((IW(KK).EQ.0).AND.(ISYM.EQ.0)) RHS(KK)=RHS(KK)-A(JJ)*RHS(II) A(JJ) = 0.0E0 70 CONTINUE GO TO 100 C C ... THE II-TH ROW IS KEPT. CHECK THE OFF-DIAGONAL ENTRIES C 80 DO 90 JJ = IBGN, IEND KK = JA(JJ) IF ( KK .EQ. II .OR. IW(KK) .EQ. 0 ) GO TO 90 RHS(II) = RHS(II) - A(JJ) * RHS(KK) A(JJ) = 0.0E0 90 CONTINUE C 100 CONTINUE C 110 RETURN C C ... ERROR TRAPS -- NO DIAGONAL ENTRY IN ROW II (ROW MAY BE EMPTY). C 120 CONTINUE IER = 102 IF(LEVEL .GE. 0) WRITE(NOUT,125) II 125 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SBELM B / 1H , 30H NO DIAGONAL ENTRY IN ROW ,I10) C RETURN END SUBROUTINE SBEND ( N, NZ, IA, JA, A, IWORK ) SBEN0010 C C*********************************************************************** C C SBEND IS THE THIRD OF A SUITE OF SUBROUTINES TO AID THE C USER TO CONSTRUCT THE IA, JA, A DATA STRUCTURE USED IN C ITPACK. C C SBEND RESTRUCTURES THE LINKED LIST DATA STRUCTURE BUILT BY C SBINI AND SBSIJ INTO THE FINAL DATA STRUCTURE REQUIRE BY C ITPACK. THE RESTRUCTURING CAN TAKE PLACE IN THE MINIMUM C AMOUNT OF MEMORY REQUIRED TO HOLD THE NONZERO STRUCTURE OF C THE SPARSE MATRIX BUT WILL RUN QUICKER IF MORE STORAGE C IS ALLOWED. C C SBEND IS BASED ON SUBROUTINE BUILD OF THE SPARSE MATRIX C PACKAGE SPARSPAK DEVELOPED BY ALAN GEORGE AND JOSEPH LUI C OF THE UNIVERSITY OF WATERLOO, WATERLOO, ONTARIO. C C ... PARAMETERS C C ...... INPUT C C N THE ORDER OF THE LINEAR SYSTEM C C NZ THE LENGTH OF THE ARRAYS JA, IWORK, AND A. C C ...... INPUT/OUTPUT C C IA INTEGER ARRAY OF LENGTH N+1. THE FIRST N ENTRIES C POINT TO THE BEGINNING OF THE LINKED LIST FOR EACH C ROW. IA(N+1)-1 IS THE TOP OF THE LINKED LISTS C CONTAINED IN JA, IWORK, AND A. ON OUTPUT IA WILL C POINT TO THE FIRST ENTRY OF EACH ROW IN THE FINAL C DATA STRUCTURE. C C JA INTEGER ARRAY OF LENGTH NZ. ON INPUT JA STORES THE C COLUMN NUMBERS OF THE NONZERO ENTRIES AS INDICATED C BY THE LINKED LISTS. ON OUTPUT JA STORES THE C COLUMN NUMBERS IN ROW ORDERED FORM. C C A REAL ARRAY OF LENGTH NZ. ON INPUT A STORES THE C VALUE OF THE NOZERO ENTRIES AS INDICATED BY THE C LINKED LISTS. ON OUTPUT A STORES THE VALUES IN C ROW ORDERED FORM. C C IWORK INTEGER ARRAY OF LENGTH NZ. ON INPUT IWORK STORES THE C THE LINKS OF THE LINKED LISTS. ON OUTPUT IT IS C DESTROYED. C C*********************************************************************** C INTEGER N, NZ, IA(1), JA(NZ), IWORK(NZ) REAL A(NZ) C INTEGER MAXTOP, NEXT, TOP, IDEG, NULINK, JAJ, HLINK, A OHLINK, L, I, LINK, MHLINK REAL VAL C C*********************************************************************** C C ... INITIALIZATION C C ...... THE VARIABLES NEXT AND TOP RESPECTIVELY POINT TO THE C NEXT AVAILABLE ENTRY FOR THE FINAL DATA STRUCTURE AND C THE TOP OF THE REMAINDER OF THE LINKED LISTS. C NEXT = 1 TOP = IA(N+1) + 1 MAXTOP = NZ - IA(N+1) + 1 C C*********************************************************************** C C ... CONVERT EACH ROW INTO FINAL FORM C DO 90 I = 1, N IDEG = 0 NULINK = IA(I) C C ... LOOP OVER EACH NODE IN THE LINKED LIST OF ROW I C 10 LINK = NULINK IF ( LINK .LE. 0 ) GO TO 80 NULINK = IWORK(LINK) JAJ = JA(LINK) VAL = A(LINK) C C ... CHECK TO SEE IF A COLLISION BETWEEN THE LINKED LISTS C AND THE FINAL FORM HAS OCCURRED. C IF ( NEXT .GE. TOP .AND. LINK .NE. TOP ) GO TO 20 C C ... COLLISION HAS NOT OCCURRED. FREE THE SPACE FOR THE TRIPLE C (JA(LINK), A(LINK), IWORK(LINK)) C JA(LINK) = 0 A(LINK) = 0.0 IWORK(LINK) = 0 C C ... SPECIAL CASE TO MOVE TOP DOWN IF LINK .EQ. TOP C IF ( LINK .EQ. TOP ) GO TO 60 GO TO 70 C C*********************************************************************** C C ... COLLISION HAS OCCURRED. CLEAR OFF SOME SPACE FOR THE CURRENT C ENTRY BY MOVING THE TRIPLE ( JA(TOP),A(TOP),IWORK(TOP) ) C DOWNWARDS TO THE FREED TRIPLE ( JA(LINK),A(LINK),IWORK(LINK) ). C THEN ADJUST THE LINK FIELDS. C C ...... PATCH UP THE LINKED LIST FOR THE CURRENT ROW I. THEN C TRAVERSE THE LINKED LIST CONTAINING TOP UNTIL THE POINTER C POINTER BACK TO IA IS FOUND. C 20 IA(I) = LINK HLINK = TOP C 30 HLINK = IWORK(HLINK) IF ( HLINK .GT. 0 ) GO TO 30 C C ...... NOW FOLLOW THE LINKED LIST BACK TO TOP KEEPING TRACK C OF THE OLD LINK. C C ......... SPECIAL CASE IF IA(-HLINK) = TOP C MHLINK = -HLINK IF ( IA(MHLINK) .NE. TOP ) GO TO 40 C IWORK(LINK) = IWORK(TOP) JA(LINK) = JA(TOP) A(LINK) = A(TOP) IA(MHLINK) = LINK IF ( NULINK .EQ. TOP ) NULINK = LINK GO TO 60 C C ......... USUAL CASE. C 40 HLINK = IA(MHLINK) 50 OHLINK = HLINK HLINK = IWORK(OHLINK) IF ( HLINK .NE. TOP ) GO TO 50 C IWORK(LINK) = IWORK(TOP) JA(LINK) = JA(TOP) A(LINK) = A(TOP) IF ( OHLINK .NE. LINK ) IWORK(OHLINK) = LINK IF ( NULINK .EQ. TOP ) NULINK = LINK C C ... COLLAPSE TOP OF LINK LIST BY AS MUCH AS POSSIBLE C 60 TOP = TOP + 1 IF ( TOP .GE. MAXTOP ) GO TO 70 IF ( IWORK(TOP) .NE. 0 ) GO TO 70 GO TO 60 C C*********************************************************************** C C ... PUT THE CURRENT TRIPLE INTO THE FINAL DATA STRUCTURE C 70 JA(NEXT) = JAJ A(NEXT) = VAL NEXT = NEXT + 1 IDEG = IDEG + 1 GO TO 10 C C ... FINAL STRUCTURE FOR ROW I IS COMPLETE. LINKED LIST IS C DESTROYED AND WILL BE RECAPTURED AS NECESSARY BY THE C LOOP ON LABEL 60 C 80 IA(I) = IDEG C 90 CONTINUE C C*********************************************************************** C C ... FINALIZE THE DATA STRUCTURE BY BUILDING THE FINAL VERSION OF C IA. C L = IA(1) + 1 IA(1) = 1 DO 100 I = 1, N IDEG = IA(I+1) IA(I+1) = L L = L + IDEG 100 CONTINUE C C ... FINAL IA, JA, A DATA STRUCTURE BUILT. C RETURN END SUBROUTINE SBINI ( N, NZ, IA, JA, A, IWORK ) SBIN0010 C C*********************************************************************** C C SBINI IS THE FIRST OF A SUITE OF THREE SUBROUTINES TO AID C THE USER TO CONSTRUCT THE IA, JA, A DATA STRUCTURE USED C IN ITPACK. C C SBINI INITIALIZES THE ARRAYS IA, JA, IWORK, AND A. THE OTHER C SUBROUTINES IN THE SUITE ARE SBSIJ ( WHICH BUILDS A LINKED C LIST REPRESENTATION OF THE MATRIX STRUCTURE ) AND SBEND ( WHICH C RESTRUCTURE THE LINKED LIST FORM INTO THE FINAL FORM ). C C ... PARAMETERS C C ...... INPUT C C N THE ORDER OF THE LINEAR SYSTEM C C NZ THE MAXIMUM NUMBER OF NONZEROES ALLOWED IN THE C LINEAR SYSTEM. C C ...... OUTPUT C C IA INTEGER ARRAY OF LENGTH N+1. SBINI SETS THIS ARRAY C TO -I FOR I = 1 THRU N. IA(N+1) IS SET TO NZ. C C JA INTEGER ARRAY OF LENGTH NZ. INITIALIZED TO ZERO HERE. C C A REAL ARRAY OF LENGTH NZ. INITIALIZED TO ZERO HERE. C C IWORK INTEGER ARRAY OF LENGTH NZ. INITIALIZED TO ZERO HERE. C C*********************************************************************** C INTEGER N, NZ, IA(1), JA(NZ), IWORK(NZ), I REAL A(NZ) C C*********************************************************************** C DO 10 I = 1, N IA(I) = -I 10 CONTINUE IA(N+1) = NZ C CALL IVFILL ( NZ, JA , 0 ) CALL IVFILL ( NZ, IWORK, 0 ) CALL VFILL ( NZ, A , 0.E0 ) C RETURN END SUBROUTINE SBSIJ(N,NZ,IA,JA,A,IWORK,II,JJ,VALL,MODE,LEVELL, SBSI0010 A NOUTT,IERR) C C*********************************************************************** C C SBSIJ IS THE SECOND OF A SUITE OF THREE SUBROUTINES TO AID IN C THE CONSTRUCTION OF THE IA, JA, A DATA STRUCTURE USED IN C ITPACK. C C SBSIJ TAKES THE INDIVIDUAL ENTRIES OF THE SPARSE MATRIX AS C GIVEN TO IT AT EACH CALL VIA (I,J,VAL) AND INSERTS IT INTO C A LINKED LIST REPRESENTATION OF THE SPARSE MATRIX. C C EACH ROW OF THE SPARSE MATRIX IS ASSOCIATED WITH A CIRCULAR C LINKED LIST BEGINNING AT IA(I). THE LAST ENTERED ELEMENT IN C EACH LIST POINTS BACK TO IA(I) WITH THE VALUE -I. THE LINKS C ARE STORED IN THE ARRAY IWORK, WHILE JA AND A STORE THE COLUMN C NUMBER AND VALUE IN PARALLEL TO IWORK. THE LINKED LISTED ARE C STORED BEGINNING AT ENTRY NZ AND WORKING BACKWARDS TOWARDS 1. C C ... PARAMETERS C C ...... INPUT C C N THE ORDER OF THE LINEAR SYSTEM C C NZ THE LENGTH OF THE ARRAYS JA, A, AND IWORK C C I, J THE ROW AND COLUMN NUMBERS OF THE ENTRY OF THE SPARSE C LINEAR SYSTEM TO BE ENTERED IN THE DATA STRUCTURE(=II,JJ) C C VAL THE NONZERO VALUE ASSOCIATED WITH (I,J) (= VALL) C C MODE IF THE (I,J) ENTRY HAS ALREADY BEEN SET, MODE SPECIFIES C THE WAY IN WHICH THE ENTRY IS TO BE TREATED. C IF MODE .LT. 0 LET THE VALUE REMAIN AS IS C .EQ. 0 RESET IT TO THE NEW VALUE C .GT. 0 ADD THE NEW VALUE TO THE OLD VALUE C C NOUT OUTPUT FILE NUMBER (= NOUTT) C C LEVEL OUTPUT FILE SWITCH (= LEVELL) C ... INPUT/OUTPUT C C IA INTEGER ARRAY OF LENGTH N+1. THE FIRST N ENTRIES C POINT TO THE BEGINNING OF THE LINKED LIST FOR EACH C ROW. IA(N+1) POINTS TO THE NEXT ENTRY AVAILABLE FOR C STORING THE CURRENT ENTRY INTO THE LINKED LIST. C C JA INTEGER ARRAY OF LENGTH NZ. JA STORES THE COLUMN C NUMBERS OF THE NONZERO ENTRIES. C C A REAL ARRAY OF LENGTH NZ. A STORES THE VALUE OF THE C NONZERO ENTRIES. C C IWORK INTEGER ARRAY OF LENGTH NZ. IWORK STORES THE LINKS. C C IER ERROR FLAG.(= IERR) POSSIBLE RETURNS ARE C IER = 0 SUCCESSFUL COMPLETION C = 700 ENTRY WAS ALREADY SET, VALUE HANDLED C AS SPECIFIED BY MODE. C = 701 IMPROPER VALUE OF EITHER I OR J INDEX C = 702 NO ROOM REMAINING, NZ TOO SMALL. C C*********************************************************************** C C INTEGER N, NZ, IA(1), JA(NZ), IWORK(NZ), II, JJ, MODE, A LEVELL, NOUTT, IERR REAL A(NZ), VALL C INTEGER LINK, NEXT, NPL1, I, J, LEVEL, NOUT, IER REAL VAL C C*********************************************************************** C C ... CHECK THE VALIDITY OF THE (I,J) ENTRY C I = II J = JJ VAL = VALL LEVEL = LEVELL NOUT= NOUTT IER = 0 IF ( I .LE. 0 .OR. I .GT. N ) IER = 701 IF ( J .LE. 0 .OR. J .GT. N ) IER = 701 IF (IER .EQ. 0) GO TO 5 IF(LEVEL .GE. 0) WRITE(NOUT,3) IER,I,J 3 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SBSIJ B / 1H , 10H IER = ,I10 C / 1H , 6H ( ,I10,3H , ,I10,2H ) D / 1H , 30H IMPROPER VALUE FOR I OR J ) GO TO 60 C C ... TRAVERSE THE LINK LIST POINTED TO BY IA(I) UNTIL EITHER C ... THE J ENTRY OR THE END OF THE LIST HAS BEEN FOUND. C 5 NPL1 = N + 1 LINK = IA(I) C C ...... SPECIAL CASE FOR THE FIRST ENTRY IN THE ROW C IF ( LINK .GT. 0 ) GO TO 10 NEXT = IA(NPL1) IF ( NEXT .LT. 1 ) GO TO 50 C IA(I) = NEXT JA(NEXT) = J A(NEXT) = VAL IWORK(NEXT) = -I IA(NPL1) = NEXT - 1 GO TO 60 C C ... FOLLOW THE LINK LIST UNTIL J OR THE END OF THE LIST IS FOUND C 10 IF ( JA(LINK) .EQ. J ) GO TO 20 IF ( IWORK(LINK) .LE. 0 ) GO TO 30 LINK = IWORK(LINK) GO TO 10 C: C ... ENTRY (I,J) ALREADY HAS BEEN SET. RESET VALUE DEPENDING ON MODE C 20 IER = 700 IF(MODE .GE. 0) GO TO 22 IF(LEVEL .GE. 1) WRITE(NOUT,21) IER,I,J,A(LINK) 21 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 30H IN ITPACK ROUTINE SBSIJ B / 1H , 10H IER = ,I10 C / 1H , 6H ( ,I10,3H , ,I10,2H ) D / 1H , 37H ENTRY ALREADY SET AND IS LEFT AS ,E15.8 ) GO TO 60 22 IF(MODE .GE. 1) GO TO 24 IF(LEVEL .GE. 1) WRITE(NOUT,23) IER,I,J,A(LINK),VAL 23 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 30H IN ITPACK ROUTINE SBSIJ B / 1H , 10H IER = ,I10 C / 1H , 6H ( ,I10,3H , ,I10,2H ) D / 1H , 40H ENTRY ALREADY SET - CURRENT VALUE OF ,E15.8 E / 1H , 40H RESET TO ,E15.8 ) A(LINK) = VAL GO TO 60 24 TEMP = A(LINK) + VAL IF(LEVEL .GE. 1) WRITE(NOUT,25) IER,I,J,A(LINK),TEMP 25 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 30H IN ITPACK ROUTINE SBSIJ B / 1H , 10H IER = ,I10 C / 1H , 6H ( ,I10,3H , ,I10,2H ) D / 1H , 40H ENTRY ALREADY SET - CURRENT VALUE OF ,E15.8 E / 1H , 40H RESET TO ,E15.8 ) A(LINK) = TEMP GO TO 60 C C ... ENTRY (I,J) HAS NOT BEEN SET. ENTER IT INTO THE LINKED LIST C 30 NEXT = IA(NPL1) IF ( NEXT .LT. 1 ) GO TO 50 C IWORK(LINK) = NEXT JA(NEXT) = J A(NEXT) = VAL IWORK(NEXT) = -I IA(NPL1) = NEXT - 1 GO TO 60 C C*********************************************************************** C C ... ERROR TRAP FOR NO ROOM REMAINING C 50 IER = 702 IF(LEVEL .GE. 0) WRITE(NOUT,55) IER 55 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SBSIJ B / 1H , 10H IER = ,I10 C / 1H , 40H NZ TOO SMALL - NO ROOM FOR NEW ENTRY ) C 60 CONTINUE IERR = IER RETURN END SUBROUTINE SCAL(NN,IA,JA,A,RHS,U,D,LEVEL,NOUT,IER) SCAL0010 C C ... ORIGINAL MATRIX IS SCALED TO A UNIT DIAGONAL MATRIX. RHS C ... AND U ARE SCALED ACCORDINGLY. THE MATRIX IS THEN SPLIT AND C ... IA, JA, AND A RESHUFFLED. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX (= NN) C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C U LATEST ESTIMATE OF SOLUTION C D OUTPUT VECTOR CONTAINING THE SQUARE ROOTS C OF THE DIAGONAL ENTRIES C LEVEL PRINTING SWITCH FOR ERROR CONDITION C NOUT OUTPUT TAPE NUMBER C IER ERROR FLAG: ON RETURN NONZERO VALUES MEAN C 401 : THE ITH DIAGONAL ELEMENT IS .LE. 0. C 402 : NO DIAGONAL ELEMENT IN ROW I C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A NN, LEVEL, NOUT, IER REAL A(1), RHS(NN), U(NN), D(NN) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I,IBGN,IEND,II,IM1,J,JADD,JAJJ,JJ,JJPI,KK,N,NP1 REAL DI C C ... EXTRACT SQUARE ROOT OF THE DIAGONAL OUT OF A AND SCALE U AND RHS C N = NN IER = 0 DO 20 II = 1,N IBGN = IA(II) IEND = IA(II+1) - 1 IF (IBGN .GT. IEND) GO TO 10 DO 5 JJ = IBGN,IEND IF (JA(JJ) .NE. II) GO TO 5 DI = A(JJ) IF (DI .GT. 0.E0) GO TO 15 IF (DI .EQ. 0.E0) GO TO 3 IER = 401 IF (LEVEL .GE. 0) WRITE (NOUT,2) II 2 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SCAL B / 1H , 26H DIAGONAL ENTRY IN ROW ,I10,9H NEGATIVE ) RETURN 3 IER = 401 IF (LEVEL .GE. 0) WRITE (NOUT,4) 4 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SCAL B / 1H , 26H DIAGONAL ENTRY IN ROW ,I10,8H IS ZERO ) RETURN 5 CONTINUE 10 IER = 402 IF(LEVEL .GE. 0) WRITE(NOUT,13) II 13 FORMAT(1H0, 40H*** F A T A L E R R O R ************ A / 1H0, 30H IN ITPACK ROUTINE SCAL B / 1H , 28H NO DIAGONAL ENTRY IN ROW ,I10) RETURN C 15 CONTINUE DI = SQRT(ABS(DI)) RHS(II) = RHS(II) / DI U(II) = U(II) * DI D(II) = DI 20 CONTINUE C C ... SHIFT MATRIX TO ELIMINATE DIAGONAL ENTRIES C IF (N .EQ. 1) GO TO 55 NP1 = N + 1 DO 50 I = 1,N IM1 = I - 1 II = NP1 - I IBGN = IA(II) IEND = IA(II+1) - 1 JADD = IBGN + IEND DO 30 J = IBGN,IEND JJ = JADD - J JJPI = JJ + IM1 IF (JA(JJ) .EQ. II) IM1 = I A(JJPI) = A(JJ) JA(JJPI) = JA(JJ) 30 CONTINUE IA(II+1) = IA(II+1) + I - 1 50 CONTINUE 55 IA(1) = IA(1) + N C C ... SCALE SHIFTED MATRIX AND STORE D ARRAY IN FIRST N ENTRIES OF A C DO 80 II = 1,N IBGN = IA(II) IEND = IA(II+1) - 1 DI = D(II) IF (IBGN .GT. IEND) GO TO 70 DO 60 JJ = IBGN,IEND JAJJ = JA(JJ) A(JJ) = A(JJ) / (DI * D(JAJJ)) 60 CONTINUE 70 CONTINUE A(II) = DI 80 CONTINUE C RETURN END SUBROUTINE SCOPY (NN,SX,INCXX,SY,INCYY) SCOP0010 C C PURPOSE - COPY A VECTOR X TO A VECTOR Y, BOTH C SINGLE PRECISION C C USAGE - CALL SCOPY (N,SX,INCX,SY,INCY) C C ARGUMENTS NN - LENGTH OF VECTORS SX AND SY. (INPUT) (= N) C SX - REAL VECTOR OF LENGTH MAX(N*IABS(INCX),1). C (INPUT) C INCX - DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT) C (= INCXX) C X(I) IS DEFINED TO BE.. C SX(1+(I-1)*INCX) IF INCX.GE.0 OR C SX(1+(I-N)*INCX) IF INCX.LT.0. C SY - REAL VECTOR OF LENGTH MAX(N*IABS(INCY),1). C (OUTPUT) C SCOPY COPIES X(I) TO Y(I) FOR I=1,...,N. C X(I) AND Y(I) REFER TO SPECIFIC ELEMENTS C OF SX AND SY, RESPECTIVELY. SEE INCX AND C INCY ARGUMENT DESCRIPTIONS. C INCY - DISPLACEMENT BETWEEN ELEMENTS OF SY. (INPUT) C (= INCYY) C Y(I) IS DEFINED TO BE.. C SY(1+(I-1)*INCY) IF INCY.GE.0 OR C SY(1+(I-N)*INCY) IF INCY.LT.0. C C SPECIFICATIONS FOR ARGUMENTS INTEGER NN,INCXX,INCYY REAL SX(NN),SY(NN) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I,IY,M,MP1,NS,IX,INCX,INCY,N C FIRST EXECUTABLE STATEMENT N = NN INCX = INCXX INCY = INCYY IF (N.LE.0) RETURN IF (INCX.EQ.INCY) IF (INCX-1) 5,15,35 5 CONTINUE C CODE FOR UNEQUAL OR NONPOSITIVE C INCREMENTS. 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) = SX(IX) IX = IX+INCX IY = IY+INCY 10 CONTINUE RETURN C CODE FOR BOTH INCREMENTS EQUAL TO 1 C CLEAN-UP LOOP SO REMAINING VECTOR C LENGTH IS A MULTIPLE OF 7. 15 M = N-(N/7)*7 IF (M.EQ.0) GO TO 25 DO 20 I=1,M SY(I) = SX(I) 20 CONTINUE IF (N.LT.7) RETURN 25 MP1 = M+1 DO 30 I=MP1,N,7 SY(I) = SX(I) SY(I+1) = SX(I+1) SY(I+2) = SX(I+2) SY(I+3) = SX(I+3) SY(I+4) = SX(I+4) SY(I+5) = SX(I+5) SY(I+6) = SX(I+6) 30 CONTINUE RETURN C CODE FOR EQUAL, POSITIVE, NONUNIT C INCREMENTS. 35 CONTINUE NS = N*INCX DO 40 I=1,NS,INCX SY(I) = SX(I) 40 CONTINUE RETURN END REAL FUNCTION SDOT (NN,SX,INCXX,SY,INCYY) SDOT0010 C C PURPOSE - COMPUTE SINGLE PRECISION DOT PRODUCT C C USAGE - FUNCTION SDOT (N,SX,INCX,SY,INCY) C C ARGUMENTS SDOT - SUM FROM I=1 TO N OF SX(I)*SY(I). (OUTPUT) C SX(I) AND SY(I) REFER TO SPECIFIC ELEMENTS C OF SX AND SY, RESPECTIVELY. SEE INCX AND C INCY ARGUMENT DESCRIPTIONS. C N - LENGTH OF VECTORS SX AND SY. (INPUT) (= NN) C SX - REAL VECTOR OF LENGTH MAX(N*IABS(INCX),1). C (INPUT) C INCX - DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT) C (= INCXX) C X(I) IS DEFINED TO BE.. C SX(1+(I-1)*INCX) IF INCX.GE.0 OR C SX(1+(I-N)*INCX) IF INCX.LT.0. C SY - REAL VECTOR OF LENGTH MAX(N*IABS(INCY),1). C (INPUT) C INCY - DISPLACEMENT BETWEEN ELEMENTS OF SY. (INPUT) C (= INCYY) C Y(I) IS DEFINED TO BE.. C SY(1+(I-1)*INCY) IF INCY.GE.0 OR C SY(1+(I-N)*INCY) IF INCY.LT.0. C C SPECIFICATIONS FOR ARGUMENTS INTEGER NN,INCXX,INCYY REAL SX(NN),SY(NN) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I,M,MP1,NS,IX,IY,INCX,INCY,N C FIRST EXECUTABLE STATEMENT N = NN INCX = INCXX INCY = INCYY SDOT = 0.0E0 IF (N.LE.0) RETURN IF (INCX.EQ.INCY) IF (INCX-1) 5,15,35 5 CONTINUE C CODE FOR UNEQUAL INCREMENTS OR C NONPOSITIVE INCREMENTS. 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 SDOT = SDOT+SX(IX)*SY(IY) IX = IX+INCX IY = IY+INCY 10 CONTINUE RETURN C CODE FOR BOTH INCREMENTS EQUAL TO 1 C CLEAN-UP LOOP SO REMAINING VECTOR C LENGTH IS A MULTIPLE OF 5. 15 M = N-(N/5)*5 IF (M.EQ.0) GO TO 25 DO 20 I=1,M SDOT = SDOT+SX(I)*SY(I) 20 CONTINUE IF (N.LT.5) RETURN 25 MP1 = M+1 DO 30 I=MP1,N,5 SDOT = SDOT+SX(I)*SY(I)+SX(I+1)*SY(I+1)+SX(I+2)*SY(I+2)+SX(I 1 +3)*SY(I+3)+SX(I+4)*SY(I+4) 30 CONTINUE RETURN C CODE FOR POSITIVE EQUAL INCREMENTS C .NE.1. 35 CONTINUE NS = N*INCX DO 40 I=1,NS,INCX SDOT = SDOT+SX(I)*SY(I) 40 CONTINUE RETURN END SUBROUTINE SUM3 (N,C1,X1,C2,X2,C3,X3) SUM30010 C C ... COMPUTES X3 = C1*X1 + C2*X2 + C3*X3 C C ... PARAMETER LIST: C C N INTEGER LENGTH OF VECTORS X1, X2, X3 C C1,C2,C3 REAL CONSTANTS C X1,X2,X3 REAL VECTORS SUCH THAT C X3(I) = C1*X1(I) + C2*X2(I) + C3*X3(I) C X3(I) = C1*X1(I) + C2*X2(I) IF C3 = 0. C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C REAL X1(N),X2(N),X3(N),C1,C2,C3 C IF (N .LE. 0 ) RETURN IF (ABS(C3) .EQ. 0.E0) GO TO 40 C DO 30 I = 1,N X3(I) = C1*X1(I) + C2*X2(I) + C3*X3(I) 30 CONTINUE RETURN C C ... COMPUTE X3 = C1*X1 + C2*X2 C 40 DO 50 I = 1,N X3(I) = C1*X1(I) + C2*X2(I) 50 CONTINUE C RETURN END REAL FUNCTION TAU (II) TAU 0010 C C ... THIS SUBROUTINE SETS TAU(II) FOR THE SOR METHOD. C C ... PARAMETER LIST: C C II NUMBER OF TIMES PARAMETERS HAVE BEEN CHANGED C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER II C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL T(8) C DATA T(1), T(2), T(3), T(4), T(5), T(6), T(7), T(8) A / 1.5E0, 1.8E0, 1.85E0, 1.9E0, 1.94E0, 1.96E0, 1.975E0, B 1.985E0 / C TAU = 1.992E0 IF (II .LE. 8) TAU = T(II) C RETURN END LOGICAL FUNCTION TSTCHG (IBMTH) TSTC0010 C C THIS FUNCTION PERFORMS A TEST TO DETERMINE IF PARAMETERS C SHOULD BE CHANGED FOR SEMI-ITERATION ACCELERATED METHODS. C C ... PARAMETER LIST: C C IBMTH INDICATOR OF BASIC METHOD BEING ACCELERATED BY SI C IBMTH = 1, JACOBI C = 2, REDUCED SYSTEM C = 3, SSOR C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IBMTH C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IP C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C IP = IN - IS IF (IBMTH .EQ. 2) IP = 2 * IP C IF (IN .EQ. 0) GO TO 10 IF (IP .LT. 3) GO TO 20 C QA = SQRT(ABS(DELNNM / DELSNM)) QT = 2.E0 * SQRT(ABS(RRR**IP)) / (1.E0 + RRR**IP) IF ((QA .GE. 1.E0) .OR. (QA .LT. QT**FF)) GO TO 20 C C ... TEST PASSES -- CHANGE PARAMETERS C 10 TSTCHG = .TRUE. RETURN C C ... TEST FAILS -- DO NOT CHANGE PARAMETERS C 20 TSTCHG = .FALSE. RETURN C END SUBROUTINE UNSCAL(N,IA,JA,A,RHS,U,D) UNSC0010 C C ... THIS SUBROUTINE REVERSES THE PROCESS OF SCAL. C C ... PARAMETER LIST: C C N DIMENSION OF MATRIX C IA,JA INTEGER ARRAYS OF SPARSE MATRIX REPRESENTATION C A REAL ARRAY OF SPARSE MATRIX REPRESENTATION C RHS RIGHT HAND SIDE OF MATRIX PROBLEM C U LATEST ESTIMATE OF SOLUTION C D VECTOR CONTAINING THE SQUARE ROOTS C OF THE DIAGONAL ENTRIES C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IA(1), JA(1), A N REAL A(1), RHS(N), U(N), D(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER IBGN, IEND, II, INEW, IS, JAJJ, JJ, JJPI REAL DI C C ... EXTRACT DIAGONAL FROM SCALED A AND UNSCALE U AND RHS C DO 10 II = 1,N DI = A(II) U(II) = U(II) / DI RHS(II) = RHS(II) * DI D(II) = DI 10 CONTINUE C C ... UNSCALE A C DO 30 II = 1,N IBGN = IA(II) IEND = IA(II+1) - 1 IF (IBGN .GT. IEND) GO TO 30 DI = D(II) DO 20 JJ = IBGN,IEND JAJJ = JA(JJ) A(JJ) = A(JJ) * DI * D(JAJJ) 20 CONTINUE 30 CONTINUE C C ... INSERT DIAGONAL BACK INTO A C DO 60 II = 1,N IBGN = IA(II) IEND = IA(II+1) - 1 IS = N - II INEW = IBGN - IS - 1 A(INEW) = D(II) ** 2 JA(INEW) = II IF (IS.EQ.0 .OR. IBGN.GT.IEND) GO TO 50 DO 40 JJ = IBGN,IEND JJPI = JJ - IS A(JJPI) = A(JJ) JA(JJPI) = JA(JJ) 40 CONTINUE 50 CONTINUE IA(II) = INEW 60 CONTINUE C RETURN END SUBROUTINE VEVMW(N,V,W) VEVM0010 C C ... VEVMW COMPUTES V = V - W C C ... PARAMETER LIST: C C N INTEGER LENGTH OF VECTORS V AND W C V REAL VECTOR C W REAL VECTOR SUCH THAT V(I) = V(I) - W(I) C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N REAL V(N), W(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, M, MP1 C IF (N .LE. 0) RETURN M = MOD(N,4) C IF (M .EQ. 0) GO TO 20 DO 10 I = 1,M V(I) = V(I) - W(I) 10 CONTINUE IF (N .LT. 4) RETURN C 20 MP1 = M + 1 DO 30 I = MP1,N,4 V(I ) = V(I ) - W(I ) V(I+1) = V(I+1) - W(I+1) V(I+2) = V(I+2) - W(I+2) V(I+3) = V(I+3) - W(I+3) 30 CONTINUE RETURN C END SUBROUTINE VEVPW(N,V,W) VEVP0010 C C ... VPW COMPUTES V = V + W C C ... PARAMETER LIST: C C N LENGTH OF VECTORS V AND W C V REAL VECTOR C W REAL VECTOR SUCH THAT V(I) = V(I) + W(I) C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N REAL V(N), W(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, M, MP1 C IF (N .LE. 0) RETURN C M = MOD(N,4) IF (M .EQ. 0) GO TO 20 DO 10 I = 1,M V(I) = V(I) + W(I) 10 CONTINUE IF (N .LT. 4) RETURN C 20 MP1 = M + 1 DO 30 I = MP1,N,4 V(I ) = V(I ) + W(I ) V(I+1) = V(I+1) + W(I+1) V(I+2) = V(I+2) + W(I+2) V(I+3) = V(I+3) + W(I+3) 30 CONTINUE C RETURN END SUBROUTINE VFILL(N,V,VAL) VFIL0010 C C FILLS A VECTOR, V, WITH A CONSTANT VALUE, VAL. C C ... PARAMETER LIST: C C N INTEGER LENGTH OF VECTOR V C V REAL VECTOR C VAL REAL CONSTANT THAT FILLS FIRST N LOCATIONS OF V C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N REAL V(N), A VAL C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, M, MP1 C IF (N .LE. 0) RETURN C C CLEAN UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 10 C M = MOD(N,10) IF (M .EQ. 0) GO TO 20 DO 10 I = 1,M 10 V(I) = VAL IF (N .LT. 10) RETURN C 20 MP1 = M + 1 DO 30 I = MP1,N,10 V(I ) = VAL V(I+1) = VAL V(I+2) = VAL V(I+3) = VAL V(I+4) = VAL V(I+5) = VAL V(I+6) = VAL V(I+7) = VAL V(I+8) = VAL V(I+9) = VAL 30 CONTINUE C RETURN END SUBROUTINE VOUT(N,V,ISWT,NOUTT) VOUT0010 C C THIS SUBROUTINE EFFECTS PRINTING OF RESIDUAL AND SOLUTION C VECTORS - CALLED FROM PERROR C C ... PARAMETER LIST: C C V VECTOR OF LENGTH N C ISWT LABELLING INFORMATION C NOUT OUTPUT DEVICE NUMBER (= NOUTT) C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N, ISWT, NOUTT REAL V(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, J, JM1, K, KUPPER, NOUT C NOUT = NOUTT C IF (N .LE. 0) RETURN C KUPPER = MIN0( N, 8) IF (ISWT .EQ. 1) WRITE (NOUT,9) 9 FORMAT(//5X,15HRESIDUAL VECTOR) IF (ISWT .EQ. 2) WRITE (NOUT,10) 10 FORMAT(//5X,15HSOLUTION VECTOR) WRITE(NOUT,11) (I,I=1,KUPPER) 11 FORMAT(10X,8I15) WRITE(NOUT,15) 15 FORMAT(10X,120(1H-) /) C DO 30 J = 1,N,8 KUPPER = MIN0(J+7,N) JM1 = J - 1 WRITE(NOUT,20) JM1,(V(K),K=J,KUPPER) 20 FORMAT(4X,I5,3H+ ,8E15.5) 30 CONTINUE C RETURN END SUBROUTINE WEVMW(N,V,W) WEVM0010 C C ... WEVMW COMPUTES W = V - W C C ... PARAMETER LIST: C C N INTEGER LENGTH OF VECTORS V AND W C V REAL VECTOR C W REAL VECTOR SUCH THAT W(I) = V(I) - W(I) C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER N REAL V(N), W(N) C C ... SPECIFICATIONS FOR LOCAL VARIABLES C INTEGER I, M, MP1 C IF (N .LE. 0) RETURN M = MOD(N,4) IF (M .EQ. 0) GO TO 20 DO 10 I = 1,M W(I) = V(I) - W(I) 10 CONTINUE IF (N .LT. 4) RETURN C 20 MP1 = M + 1 DO 30 I = MP1,N,4 W(I ) = V(I ) - W(I ) W(I+1) = V(I+1) - W(I+1) W(I+2) = V(I+2) - W(I+2) W(I+3) = V(I+3) - W(I+3) 30 CONTINUE C RETURN END SUBROUTINE ZBRENT (N,TRI,EPS,NSIG,AA,BB,MAXFNN,IER) ZBRE0010 C MODIFIED IMSL ROUTINE NAME - ZBRENT C C----------------------------------------------------------------------- C C COMPUTER - CDC/SINGLE C C LATEST REVISION - JANUARY 1, 1978 C C PURPOSE - ZERO OF A FUNCTION WHICH CHANGES SIGN IN A C GIVEN INTERVAL (BRENT ALGORITHM) C C USAGE - CALL ZBRENT (F,EPS,NSIG,A,B,MAXFN,IER) C C ARGUMENTS TRI - A TRIDIAGONAL MATRIX OF ORDER N C EPS - FIRST CONVERGENCE CRITERION (INPUT). A ROOT, C B, IS ACCEPTED IF ABS(F(B)) IS LESS THAN OR C EQUAL TO EPS. EPS MAY BE SET TO ZERO. C NSIG - SECOND CONVERGENCE CRITERION (INPUT). A ROOT, C B, IS ACCEPTED IF THE CURRENT APPROXIMATION C AGREES WITH THE TRUE SOLUTION TO NSIG C SIGNIFICANT DIGITS. C A,B - ON INPUT, THE USER MUST SUPPLY TWO POINTS, A C AND B, SUCH THAT F(A) AND F(B) ARE OPPOSITE C IN SIGN. (= AA, BB) C ON OUTPUT, BOTH A AND B ARE ALTERED. B C WILL CONTAIN THE BEST APPROXIMATION TO THE C ROOT OF F. SEE REMARK 1. C MAXFN - ON INPUT, MAXFN SHOULD CONTAIN AN UPPER BOUND C ON THE NUMBER OF FUNCTION EVALUATIONS C REQUIRED FOR CONVERGENCE. ON OUTPUT, MAXFN C WILL CONTAIN THE ACTUAL NUMBER OF FUNCTION C EVALUATIONS USED. (= MAXFNN) C IER - ERROR PARAMETER. (OUTPUT) C TERMINAL ERROR C IER = 501 INDICATES THE ALGORITHM FAILED TO C CONVERGE IN MAXFN EVALUATIONS. C IER = 502 INDICATES F(A) AND F(B) HAVE THE C SAME SIGN. C C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 C - SINGLE/H36,H48,H60 C C C NOTATION - INFORMATION ON SPECIAL NOTATION AND C CONVENTIONS IS AVAILABLE IN THE MANUAL C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP C C REMARKS 1. LET F(X) BE THE CHARACTERISTIC FUNCTION OF THE MATRIX C TRI EVALUATED AT X. FUNCTION DETERM EVALUATES F(X). C ON EXIT FROM ZBRENT, WHEN IER=0, A AND B SATISFY THE C FOLLOWING, C F(A)*F(B) .LE.0, C ABS(F(B)) .LE. ABS(F(A)), AND C EITHER ABS(F(B)) .LE. EPS OR C ABS(A-B) .LE. MAX(ABS(B),0.1)*10.0**(-NSIG). C THE PRESENCE OF 0.1 IN THIS ERROR CRITERION CAUSES C LEADING ZEROES TO THE RIGHT OF THE DECIMAL POINT TO BE C COUNTED AS SIGNIFICANT DIGITS. SCALING MAY BE REQUIRED C IN ORDER TO ACCURATELY DETERMINE A ZERO OF SMALL C MAGNITUDE. C 2. ZBRENT IS GUARANTEED TO REACH CONVERGENCE WITHIN C K = (ALOG((B-A)/D)+1.0)**2 FUNCTION EVALUATIONS WHERE C D=MIN(OVER X IN (A,B) OF C MAX(ABS(X),0.1)*10.0**(-NSIG)). C THIS IS AN UPPER BOUND ON THE NUMBER OF EVALUATIONS. C RARELY DOES THE ACTUAL NUMBER OF EVALUATIONS USED BY C ZBRENT EXCEED SQRT(K). D CAN BE COMPUTED AS FOLLOWS, C P = AMIN1(ABS(A),ABS(B)) C P = AMAX1(0.1,P) C IF ((A-0.1)*(B-0.1).LT.0.0) P = 0.1 C D = P*10.0**(-NSIG) C C COPYRIGHT - 1977 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C C DESCRIPTION OF VARIABLES IN COMMON BLOCK IN MAIN SUBROUTINE C C SPECIFICATIONS FOR ARGUMENTS INTEGER NSIG,MAXFNN,IER REAL TRI(2,1),EPS,AA,BB C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER IC,MAXFN REAL ZERO,HALF,ONE,THREE,TEN,A,B 1 T,FA,FB,C,FC,D,E,TOL,RM,S,P,Q,R,RONE,TEMP DATA ZERO/0.E0/,HALF/5.E-1/,ONE/1.E0/,THREE/3.E0/, 1 TEN/10.E0/ C C C FIRST EXECUTABLE STATEMENT A = AA B = BB MAXFN = MAXFNN IER = 0 T = TEN**(-NSIG) IC = 2 FA = DETERM(N,TRI,A) FB = DETERM(N,TRI,B) S = B C TEST FOR SAME SIGN IF (FA*FB.GT.ZERO) GO TO 50 5 C = A FC = FA D = B-C E = D 10 IF (ABS(FC).GE.ABS(FB)) GO TO 15 A = B B = C C = A FA = FB FB = FC FC = FA 15 CONTINUE TOL = T*AMAX1(ABS(B),0.1) RM = (C-B)*HALF C TEST FOR FIRST CONVERGENCE CRITERIA IF (ABS(FB).LE.EPS) GO TO 40 C TEST FOR SECOND CONVERGENCE CRITERIA IF (ABS(C-B).LE.TOL) GO TO 40 C CHECK EVALUATION COUNTER IF (IC.GE.MAXFN) GO TO 45 C IS BISECTION FORCED IF (ABS(E).LT.TOL) GO TO 30 IF (ABS(FA).LE.ABS(FB)) GO TO 30 S = FB/FA IF (A .NE. C) GO TO 20 C LINEAR INTERPOLATION P = (C-B)*S Q = ONE-S GO TO 25 C INVERSE QUADRATIC INTERPOLATION 20 Q = FA/FC R = FB/FC RONE = R-ONE P = S*((C-B)*Q*(Q-R)-(B-A)*RONE) Q = (Q-ONE)*RONE*(S-ONE) 25 IF (P.GT.ZERO) Q = -Q IF (P.LT.ZERO) P = -P S = E E = D C IF ABS(P/Q).GE.75*ABS(C-B) THEN C FORCE BISECTION IF (P+P.GE.THREE*RM*Q) GO TO 30 C IF ABS(P/Q).GE..5*ABS(S) THEN FORCE C BISECTION. S = THE VALUE OF P/Q C ON THE STEP BEFORE THE LAST ONE IF (P+P.GE.ABS(S*Q)) GO TO 30 D = P/Q GO TO 35 C BISECTION 30 E = RM D = E C INCREMENT B 35 A = B FA = FB TEMP = D IF (ABS(TEMP).LE.HALF*TOL) TEMP = SIGN(HALF*TOL,RM) B = B+TEMP S = B FB = DETERM(N,TRI,S) IC = IC+1 IF (FB*FC.LE.ZERO) GO TO 10 GO TO 5 C CONVERGENCE OF B 40 A = C MAXFN = IC GO TO 9000 C MAXFN EVALUATIONS 45 IER = 501 A = C MAXFN = IC IF(LEVEL .GE. 1) WRITE(NOUT,47) MAXFN 47 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 30H IN ITPACK ROUTINE ZBRENT B / 1H , 35H ALGORITHM FAILED TO CONVERGE C / 1H , 6H IN ,I6,12H ITERATIONS ) GO TO 9000 C TERMINAL ERROR - F(A) AND F(B) HAVE C THE SAME SIGN 50 IER = 502 MAXFN = IC IF(LEVEL .GE. 1) WRITE(NOUT,53) 53 FORMAT(1H0, 30H*** W A R N I N G ************ A / 1H0, 30H IN ITPACK ROUTINE ZBRENT B / 1H , 35H F(A) AND F(B) HAVE SAME SIGN ) 9000 CONTINUE AA = A BB = B MAXFNN = MAXFN RETURN END SUBROUTINE DFAULT(IPARM,RPARM) DFAU0010 C C ... THIS SUBROUTINE SETS THE DEFAULT VALUES OF IPARM AND RPARM. C C ... PARAMETER LIST: C C IPARM C AND C RPARM ARRAYS SPECIFYING OPTIONS AND TOLERANCES C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER IPARM(12) REAL RPARM(12) C C *** BEGIN: ITPACK COMMON C INTEGER IN, IS, ISYM, ITMAX, LEVEL, NOUT COMMON /ITCOM1/ IN, IS, ISYM, ITMAX, LEVEL, NOUT C LOGICAL ADAPT, BETADT, CASEII, HALT, PARTAD COMMON /ITCOM2/ ADAPT, BETADT, CASEII, HALT, PARTAD C REAL BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA COMMON /ITCOM3/ BDELNM,BETAB,CME,DELNNM,DELSNM,FF,GAMMA,OMEGA, A QA,QT,RHO,RRR,SIGE,SME,SPECR,SPR,SRELPR,STPTST,UDNM,ZETA C C *** END : ITPACK COMMON C C DESCRIPTION OF VARIABLES IN COMMON BLOCKS IN MAIN SUBROUTINE C C SRELPR - COMPUTER PRECISION (APPROX.) C IF INSTALLER OF PACKAGE DOES NOT KNOW SRELPR VALUE, C AN APPROXIMATE VALUE CAN BE DETERMINED FROM A SIMPLE C FORTRAN PROGRAM SUCH AS C C SRELPR = 1.0 C 2 SRELPR = 0.5*SRELPR C TEMP = SRELPR + 1.0 C IF(TEMP .GT. 1.0) GO TO 2 C WRITE(6,3) SRELPR C 3 FORMAT(5X,E15.8) C STOP C END C C C SOME VALUES ARE: C C SRELPR = 7.1E-15 FOR CDC CYBER 170/750 (APPROX.) 2**-47 C = 1.49E-8 FOR DEC 10 (APPROX.) 2**-26 C = 1.192E-7 FOR VAX 11/780 (APPROX) 2**-23 C = 4.768E-7 FOR IBM 370/158 C C *** SHOULD BE CHANGED FOR OTHER MACHINES *** C C TO FACILITATE CONVERGENCE, RPARM(1) SHOULD BE SET TO C 500.*SRELPR OR LARGER C SRELPR = 7.1E-15 C IPARM(1) = 100 IPARM(2) = 0 IPARM(3) = 0 IPARM(4) = 6 IPARM(5) = 0 IPARM(6) = 1 IPARM(7) = 1 IPARM(8) = 0 IPARM(9) = -1 IPARM(10) = 0 IPARM(11) = 0 IPARM(12) = 0 C RPARM(1) = 0.5E-5 RPARM(2) = 0.E0 RPARM(3) = 0.E0 RPARM(4) = .75E0 RPARM(5) = 1.E0 RPARM(6) = 0.E0 RPARM(7) = .25E0 RPARM(8) = 1.E2*SRELPR RPARM(9) = 0.E0 RPARM(10) = 0.E0 RPARM(11) = 0.E0 RPARM(12) = 0.E0 C RETURN END INTEGER FUNCTION ITICK(M) ITIC0010 C C ... ITICK IS AN INTEGER FUNCTION TO RETURN THE EXECUTION TIME IN C ... MILLISECONDS AT THE BEGINNING OF A TIMING INTERVAL. ITICK C ... USES A LOCAL TIMING FUNCTION CPTIME WHICH RETURNS (IN SECONDS) C ... THE CURRENT EXECUTION TIME. C C ... PARAMETER LIST: C C M INTEGER DUMMY ARGUMENT (NOT USED) C C C NOTE: ON MANY COMPUTER SYSTEMS THERE IS A CPU-TIME SUBPROGRAM C SUCH AS CPTIME WHICH IS MORE ACCURATE THAN THE FORTRAN C SUBROUTINE SECOND. C C C REPLACE WITH THE FOLLOWING FOR USE WITH SECOND C C CALL SECOND(TIMDMY) C ITICK = IFIX( TIMDMY * 1.E3 + 5.E-1 ) C C REPLACE WITH THE FOLLOWING FOR DEC10 COMPUTER C C ITIME = 0 C ISKIP = ICALLI(ITIME,"27) C ITICK = ITIME C C ********************************************* C ** ** C ** THIS FUNCTION IS NOT PORTABLE. ** C ** ** C ********************************************* C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER M C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL TIMDMY C ITICK = IFIX(CPTIME(TIMDMY) * 1.E3 + 5.E-1) C RETURN END INTEGER FUNCTION ITOCK(M) ITOC0010 C C ... ITOCK IS AN INTEGER FUNCTION TO RETURN THE EXECUTION TIME IN C ... MILLISECONDS AT THE END OF A TIMING INTERVAL. ITOCK C ... USES A LOCAL TIMING FUNCTION CPTIME WHICH RETURNS (IN SECONDS) C ... THE CURRENT EXECUTION TIME. C C ... PARAMETER LIST: C C M INTEGER DUMMY ARGUMENT (NOT USED) C C C NOTE: ON MANY COMPUTER SYSTEMS THERE IS A CPU-TIME SUBPROGRAM C SUCH AS CPTIME WHICH IS MORE ACCURATE THAN THE FORTRAN C SUBROUTINE SECOND. C C C REPLACE WITH THE FOLLOWING FOR USE WITH SECOND C C CALL SECOND(TIMDMY) C ITOCK = IFIX( TIMDMY * 1.E3 + 5.E-1 ) C C REPLACE WITH THE FOLLOWING FOR DEC10 COMPUTER C C ITIME = 0 C ISKIP = ICALLI(ITIME,"27) C ITOCK = ITIME C C ********************************************* C ** ** C ** THIS FUNCTION IS NOT PORTABLE. ** C ** ** C ********************************************* C C ... SPECIFICATIONS FOR ARGUMENTS C INTEGER M C C ... SPECIFICATIONS FOR LOCAL VARIABLES C REAL TIMDMY C ITOCK = IFIX(CPTIME(TIMDMY) * 1.E3 + 5.E-1) C RETURN END C PROGRAM MAIN (OUTPUT, TAPE6=OUTPUT) MAIN 10 C MAIN 20 C CHANGES TO BE MADE FOR USE ON DIFFERENT COMPUTERS: MAIN 30 C 1. REMOVE OR CHANGE PROGRAM LINE ABOVE OR OPEN LINE BELOW MAIN 40 C 2. CHANGE THE VALUE OF SRELPR BELOW AND IN ITPACK ROUTINE DFAULT MAIN 50 C 3. CHANGES IN THE ITPACK TIMING ROUTINES ITOCK AND ITICK MAIN 60 C MAIN 70 C OPEN(UNIT=6,DEVICE='DSK',ACCESS='SEQOUT',FILE='OUT.LPT') MAIN 80 C MAIN 90 C MAIN 100 C MACHINE PRECISION SRELPR MAIN 110 C MAIN 120 C SRELPR = 7.1E-15 FOR CDC CYBER 170/750 (APPROX.) 2**-47 MAIN 130 C = 1.49E-8 FOR DEC 10 (APPROX.) 2**-26 MAIN 140 C = 1.192E-7 FOR VAX 11/780 (APPROX.) 2**-23 MAIN 150 C = 9.534E-7 FOR IBM 370 (APPROX.) MAIN 160 C MAIN 170 SRELPR = 7.1E-15 MAIN 180 CALL TEST1(SRELPR) MAIN 190 CALL TEST2(SRELPR) MAIN 200 CALL TEST3(SRELPR) MAIN 210 CALL TEST4(SRELPR) MAIN 220 STOP MAIN 230 END MAIN 240 SUBROUTINE TEST1(EPSI) TEST0010 C C ... TEST1 IS A PROGRAM DESIGNED TO TEST ITPACK 2C METHODS ON C ... MATRICES ARISING FROM THE SYMMETRIC FIVE POINT DISCRETIZATION C ... OF TWO DIMENSIONAL ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS ON C ... A RECTANGLE WITH A RECTANGULAR MESH. ALL SEVEN METHODS FROM C ... ITPACK 2C ARE TESTED AND A SUMMARY IS PRINTED AT THE END. C C THE EXACT SIZE OF THE TEST PROBLEMS CAN BE INCREASED OR C DECREASED BY CHANGING THE ARRAY SIZE IN DIMENSION STATEMENTS C AND THE VARIABLES LISTED BELOW UNDER SIZE OF TEST PROBLEM. C ALSO, THE NUMBER OF TIMES THROUGH THE TEST LOOPS CAN BE REDUCED C BY CHANGING ITEST AND JTEST AS FOLLOWS. C C ITEST = 1 FOR SYMMETRIC STORAGE TEST C = 2 FOR SYMMETRIC AND NONSYMMETRIC STORAGE TEST C JTEST = 1 FOR NATURAL ORDERING TEST C = 2 FOR NATURAL AND RED-BLACK ORDERING TEST C C ARRAY DIMENSIONING C REAL A(1729),RHS(361),U(361),WKSP(2606),RPARM(12), A GRIDX(21),GRIDY(21),DIGIT1(7),DIGIT2(7),TIM1(7),TIM2(7) INTEGER IA(362),JA(1729),IWKSP(1083),IPARM(12),IWORK(1729), A BCTYPE(4),ITER(7),IWRK(7) C C ... SYM5PT COMMON BLOCKS C COMMON /TBK11/ AX, AY, BX, BY, SRELPR, HX, HY COMMON /TBK12/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,N C C C ... INITIALIZE INTEGER CONSTANTS WHICH CONTROL OUTPUT AND DEFINE C ... ARRAY DIMENSIONS. THEY ARE C C SRELPR - MACHINE PRECISION C NOUT - FORTRAN OUTPUT UNIT C LEVEL - LEVEL OF OUTPUT FROM ITPACK 2C C IERAN - ERROR ANALYSIS SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C ZETA - STOPPING CRITERION C NW - SIZE OF THE REAL ARRAY WKSP. C ILEVEL - 0/1 LEVEL OF OUTPUT FROM SYM7PT C MXNEQ - MAXIMUM NUMBER OF EQUATIONS TO BE GENERATED (I.E. C THE MAXIMUM NUMBER OF INTERIOR AND NON-DIRICHLET C BOUNDARY POINTS) C NELMAX - MAXIMUM NUMBER OF NON-ZERO ENTRIES IN THE UPPER C TRIANGULAR PART OF THE RESULTING SYMMETRIC MATRIX C NGRIDX - NUMBER OF HORIZONTAL MESH PLANES. C NGRIDY - NUMBER OF VERTICAL MESH PLANES. C NGRDXD - MAXIMUM NUMBER OF VERTICAL MESH PLANES INCLUDING THE C VERTICAL BOUNDARY PLANES. C NGRDYD - MAXIMUM NUMBER OF HORIZONTAL MESH PLANES INCLUDING C THE HORIZONTAL BOUNDARY PLANES. C SRELPR = EPSI C C SET ITPACK SWITCHES C NOUT = 6 LEVEL = 1 IERAN = 0 ITMAX = 110 ZETA = 0.5E-5 NW = 2606 C C SET NUMBER OF TIMES THROUGH TEST LOOPS C ITEST = 2 JTEST = 2 C C SET SIZE OF TEST PROBLEM C ILEVEL = 0 MXNEQ = 361 NELMAX = 1729 NGRIDX = 21 NGRIDY = 21 C NGRDXD = NGRIDX NGRDYD = NGRIDY WRITE(NOUT,10) 10 FORMAT(1H1 //15X,32HITPACK 2C TEST PROGRAM -- TEST1 A /15X,23HTESTS ITERATIVE MODULES B /15X,40HUSES FIVE POINT SYMMETRIC DISCRETIZATION ) C C ... SET UP DEFAULT VALUES FOR BCTYPE AND INITIALIZE INFORMATION ARRAYS C C ... BCTYPE DEFINES THE BOUNDARY CONDITIONS ON THE EDGES OF THE C ... RECTANGLE. WHERE C C BCTYPE(I) = 0 IMPLIES THE ITH SIDE IS NEUMANN OR MIXED C = 1 IMPLIES THE ITH SIDE IS DIRICHLET C C AND I = 1 IMPLIES THE EAST SIDE DEFINED BY (BX, Y) C = 2 IMPLIES THE SOUTH SIDE DEFINED BY ( X,AY) C = 3 IMPLIES THE WEST SIDE DEFINED BY (AX, Y) C = 4 IMPLIES THE NORTH SIDE DEFINED BY ( X,BY) C DO 20 I = 1,4 BCTYPE(I) = 1 20 CONTINUE C C ... DEFINE THE DISCRETIZATION MESH C C AX - MINIMUM X VALUE ON THE RECTANGLE (WEST SIDE) C BX - MAXIMUM X VALUE ON THE RECTANGLE (EAST SIDE) C GRIDX - REAL ARRAY CONTAINING THE X-COORDINATE OF THE C HORIZONTAL MESH LINES FROM WEST TO EAST. C THESE ARE UNIFORM BUT THAT IS NOT REQUIRED. C AY - MINIMUM Y VALUE ON THE RECTANGLE (SOUTH SIDE) C BY - MAXIMUM Y VALUE ON THE RECTANGLE (NORTH SIDE) C GRIDY - REAL ARRAY CONTAINING THE Y-COORDINATE OF THE C VERTICAL MESH LINES FROM SOUTH TO NORTH. C THESE ARE UNIFORM BUT THAT IS NOT REQUIRED. C AX = 0.E0 BX = 1.E0 HX = (BX-AX)/ FLOAT(NGRIDX-1) DO 40 J = 1, NGRIDX GRIDX(J) = AX + FLOAT(J-1)*HX 40 CONTINUE GRIDX(NGRIDX) = BX C AY = 0.E0 BY = 1.E0 HY = (BY-AY)/ FLOAT(NGRIDY-1) DO 50 J = 1, NGRIDY GRIDY(J) = AY + FLOAT(J-1)*HY 50 CONTINUE GRIDY(NGRIDY) = BY C C ... DISCRETIZE THE ELLIPTIC PDE C DO 60 LOOP1=1,ITEST ISYM = LOOP1 - 1 IF(LOOP1 .EQ. 2) WRITE(NOUT,63) 63 FORMAT(1H1///) CALL SYM5PT(GRIDX,NGRDXD,GRIDY,NGRDYD,RHS,MXNEQ,IA,JA,A,NELMAX, A IWORK) C C C ... SOLVE THE MATRIX PROBLEM C DO 60 LOOP2=1,JTEST NB = LOOP2 - 2 IF(ISYM .EQ. 0) WRITE(NOUT,91) IF(ISYM .EQ. 1) WRITE(NOUT,92) IF(NB .EQ. (-1)) WRITE(NOUT,93) IF(NB .EQ. 0) WRITE(NOUT,94) C C TEST JCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL JCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(1)=RPARM(9) TIM2(1)=RPARM(10) DIGIT1(1)=RPARM(11) DIGIT2(1)=RPARM(12) ITER(1)=IPARM(1) IWRK(1)=IPARM(8) C C TEST JSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL JSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(2)=RPARM(9) TIM2(2)=RPARM(10) DIGIT1(2)=RPARM(11) DIGIT2(2)=RPARM(12) ITER(2)=IPARM(1) IWRK(2)=IPARM(8) C C TEST SOR C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SOR (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(3)=RPARM(9) TIM2(3)=RPARM(10) DIGIT1(3)=RPARM(11) DIGIT2(3)=RPARM(12) ITER(3)=IPARM(1) IWRK(3)=IPARM(8) C C TEST SSORCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SSORCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) ITER(4)=IPARM(1) IWRK(4)=IPARM(8) TIM1(4)=RPARM(9) TIM2(4)=RPARM(10) DIGIT1(4)=RPARM(11) DIGIT2(4)=RPARM(12) C C TEST SSORSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SSORSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(5)=RPARM(9) TIM2(5)=RPARM(10) DIGIT1(5)=RPARM(11) DIGIT2(5)=RPARM(12) ITER(5)=IPARM(1) IWRK(5)=IPARM(8) C C TEST RSCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL RSCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(6)=RPARM(9) TIM2(6)=RPARM(10) DIGIT1(6)=RPARM(11) DIGIT2(6)=RPARM(12) ITER(6)=IPARM(1) IWRK(6)=IPARM(8) C C TEST RSSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL RSSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(7)=RPARM(9) TIM2(7)=RPARM(10) DIGIT1(7)=RPARM(11) DIGIT2(7)=RPARM(12) ITER(7)=IPARM(1) IWRK(7)=IPARM(8) C C TIMING ANALYSIS C CALL TIME1 (N,IA,JA,A,WKSP,WKSP(N+1),ITER,TIM1,TIM2, A DIGIT1,DIGIT2,IWRK,NOUT) 60 CONTINUE C 91 FORMAT(//15X,29HSYMMETRIC SPARSE STORAGE USED ) 92 FORMAT(//15X,32HNONSYMMETRIC SPARSE STORAGE USED ) 93 FORMAT(15X,21HNATURAL ORDERING USED ) 94 FORMAT(15X,23HRED-BLACK ORDERING USED ) RETURN END SUBROUTINE TIME1 (N,IA,JA,A,V,W,ITER,TIM1,TIM2,DIGIT1,DIGIT2, TIME0010 A IWORK,NOUT) INTEGER ITER(7),IA(1),JA(1),IWORK(7) REAL V(N),W(N),REL(7),A(1),DIGIT1(7),DIGIT2(7), A TIM1(7),TIM2(7) DATA MAXLP/20/ C CALL VFILL (N,V,1.E0) ITIM1 = ITICK(NDUMMY) DO 10 I=1,MAXLP CALL PMULT (N,IA,JA,A,V,W) 10 CONTINUE ITIM2 = ITOCK(NDUMMY) TIMMAT = AMAX0(0,ITIM2 - ITIM1)*1.0E-3/FLOAT(MAXLP) C WRITE (NOUT,30) DO 20 I=1,7 REL(I) = 0.E0 TEMP = FLOAT(ITER(I)) IF ((ITIM2 .EQ. ITIM1) .OR. (ITER(I) .EQ. 0)) GO TO 20 REL(I) = TIM1(I)/(TEMP*TIMMAT) 20 CONTINUE C WRITE (NOUT,40) (TIM1(I),TIM2(I),ITER(I),REL(I),DIGIT1(I), A DIGIT2(I),IWORK(I),I=1,7) C RETURN C 30 FORMAT(1H0,3(/),15X,15HTIMING ANALYSIS/15X,15(1H-)// A 35X,9HITERATION,3X,5HTOTAL,9X,6HNO. OF,4X,9HAVG ITER/, B 2X,6HDIGITS,4X,6HDIGITS,5X,4HWKSP/15X, C 6HMETHOD,14X,10HTIME (SEC),2X,10HTIME (SEC),1X, D 10HITERATIONS,1X,12HMTX-VCTR MLT,1X,7HSTP TST, E 3X,7HRES/RHS,4X,4HUSED/15X,103(1H-)) 40 FORMAT(15X,17HJACOBI CG ,2F10.3,I14,F10.1,1X,2F10.1,I10/ 2 15X,17HJACOBI SI ,2F10.3,I14,F10.1,1X,2F10.1,I10/ 3 15X,17HSOR ,2F10.3,I14,F10.1,1X,2F10.1,I10/ 4 15X,17HSYMMETRIC SOR CG ,2F10.3,I14,F10.1,1X,2F10.1,I10/ 5 15X,17HSYMMETRIC SOR SI ,2F10.3,I14,F10.1,1X,2F10.1,I10/ 6 15X,17HREDUCED SYSTEM CG,2F10.3,I14,F10.1,1X,2F10.1,I10/ 7 15X,17HREDUCED SYSTEM SI,2F10.3,I14,F10.1,1X,2F10.1,I10/) C C END SUBROUTINE PDE1(X,Y,CVALUS) PDE10010 C C ... THIS SUBROUTINE IS A USER SUPPLIED SUBROUTINE TO SPECIFY THE C ... SELF-ADJOINT ELLIPTIC PDE FOR SYM5PT IN THE FOLLOWING FORM C C (CVALUS(1)*UX)X + (CVALUS(3)*UY)Y + CVALUS(6)*U = CVALUS(7) C C NOTE: CVALUS(I), FOR I = 2, 4, AND 5 ARE NOT USED. C REAL CVALUS(7) C CVALUS( 1) = 1.E0 CVALUS( 2) = 0.E0 CVALUS( 3) = 2.E0 CVALUS( 4) = 0.E0 CVALUS( 5) = 0.E0 CVALUS( 6) = 0.E0 CVALUS( 7) = 0.E0 C RETURN END REAL FUNCTION BCOND1(ISIDE,X,Y,BVALUS) BCON0010 C C ... THIS REAL FUNCTION IS A USER SUPPLIED FUNCTION TO SPECIFY THE C ... BOUNDARY CONDITIONS OF THE ELLIPTIC PDE DEPENDING ON ISIDE, X, C ... AND Y. C C IF ISIDE = 1, THEN X = BX (EAST SIDE) C = 2, THEN Y = AY (SOUTH SIDE) C = 3, THEN X = AX (WEST SIDE) C = 4, THEN Y = BY (NORTH SIDE) C C ... THE BVALUS ARRAY IS DEFINED AS FOLLOWS C C BVALUS(1)*U + BVALUS(2)*UX + BVALUS(3)*UY = BVALUS(4) C C NOTE: BCOND1 IS SET TO BVALUS(4) BEFORE RETURNING. C REAL BVALUS(4) C GOTO(10,20,30,40),ISIDE C 10 BVALUS(1) = 1.E0 BVALUS(4) = 1.E0+ X * Y BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 GO TO 999 C 20 BVALUS(1) = 1.E0 BVALUS(4) = 1.E0+ X * Y BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 GO TO 999 C 30 BVALUS(1) = 1.E0 BVALUS(4) = 1.E0+ X * Y BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 GO TO 999 C 40 BVALUS(1) = 1.E0 BVALUS(4) = 1.E0+ X * Y BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 C 999 BCOND1 = BVALUS(4) RETURN END SUBROUTINE SYM5PT (GRIDX,NGRDXD,GRIDY,NGRDYD,RHS, SYM50010 A MXNEQ,IA,JA,A,NELS,IWKSP) C INTEGER IA(1),JA(NELS),BCTYPE(4),IWKSP(NELS) REAL GRIDX(NGRDXD),GRIDY(NGRDYD),RHS(MXNEQ),A(NELS) C C C ... SYM5PT / SYM7PT COMMON BLOCKS C COMMON /TBK11/ AX, AY, BX, BY, SRELPR, HX, HY COMMON /TBK12/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,N C C IF (NGRIDX .LT. 3 .OR. NGRIDY .LT. 3) GO TO 120 C C DETERMINE RANGE OF UNKNOWN GRID POINTS C IX1 = 1 IX2 = NGRIDX JY1 = 1 JY2 = NGRIDY IF (BCTYPE(1) .EQ. 1) IX2 = NGRIDX - 1 IF (BCTYPE(2) .EQ. 1) JY1 = 2 IF (BCTYPE(3) .EQ. 1) IX1 = 2 IF (BCTYPE(4) .EQ. 1) JY2 = NGRIDY - 1 LNGTHX = IX2 - IX1 + 1 N = (JY2 - JY1 + 1) * LNGTHX IF (N .GT. MXNEQ) GO TO 260 C C OUTPUT INITIAL GRID INFORMATION C IF (ILEVEL .EQ. 0) GO TO 70 WRITE(NOUT,20) AX,BX,AY,BY 20 FORMAT(/10X,24HFINITE DIFFERENCE MODULE ,6H ---- , A 20HSYMMETRIC FIVE POINT /10X,21HDOMAIN = RECTANGLE (, B E11.4,1H,,E11.4,5H) X (,E11.4,1H,,E11.4,1H) ) C WRITE(NOUT,30) 30 FORMAT(/10X,35HCOEFFICIENTS OF VERTICAL MESH LINES ) WRITE(NOUT,40) (GRIDX(I),I=1,NGRIDX) 40 FORMAT(/8X,8(2X,E11.4) ) WRITE(NOUT,50) 50 FORMAT(/10X,37HCOEFFICIENTS OF HORIZONTAL MESH LINES ) WRITE(NOUT,40) (GRIDY(I),I=1,NGRIDY) WRITE(NOUT,60) (BCTYPE(I), I=1,4) 60 FORMAT(/10X,42HBOUNDARY CONDITIONS ON PIECES 1,2,3,4 ARE , A 3(1X,I1,1H,),1X,I1,1H. ) C C GENERATE EQUATIONS ONE MESH POINT AT A TIME C 70 CALL SBINI(N,NELS,IA,JA,A,IWKSP) IXADD = 0 JYADD = 0 IF (BCTYPE(3) .EQ. 1) IXADD = 1 IF (BCTYPE(2) .EQ. 1) JYADD = 1 C DO 100 IJ = 1,N IXX = MOD(IJ-1,LNGTHX) + 1 JYY = (IJ - IXX) / LNGTHX + 1 IXX = IXX + IXADD JYY = JYY + JYADD HN = 0.E0 HS = 0.E0 HE = 0.E0 HW = 0.E0 PX = GRIDX(IXX) PY = GRIDY(JYY) IF (IXX .NE. 1) HW = PX - GRIDX(IXX - 1) IF (IXX .NE. NGRIDX) HE = GRIDX(IXX+1) - PX IF (JYY .NE. 1) HS = PY - GRIDY(JYY - 1) IF (JYY .NE. NGRIDY) HN = GRIDY(JYY+1) - PY C INIJ=IJ CALL PNT2D(PX,PY,INIJ,IXX,JYY,LNGTHX,HN,HS,HW,HE, A B,NELS,IA,JA,A,IWKSP) C RHS(IJ) = B 100 CONTINUE C CALL SBEND(N,NELS,IA,JA,A,IWKSP) C NORMAL EXIT C IF (ILEVEL .EQ. 0) RETURN C WRITE(NOUT,110) 110 FORMAT(/10X,30HSYM5PT COMPLETED SUCCESSFULLY. ) NU = IA(N+1) - 1 NUU = N + 1 + 2*NU WRITE(NOUT,115) N,NU,NUU 115 FORMAT( 10X,38HSPARSE MATRIX REPRESENTATION FINISHED. A /15X,25HNO. OF EQUATIONS =,I8 B /15X,25HNO. OF NON-ZEROES =,I8 C /15X,25HTOTAL MATRIX STORAGE =,I8 /) C RETURN C C ERROR EXITS C 120 CONTINUE IF (NGRIDX .LT. 3) WRITE(NOUT,160) 160 FORMAT(/10X,30HSYM5PT ERROR -- NGRIDX .LT. 3 ) IF (NGRIDY .LT. 3) WRITE(NOUT,170) 170 FORMAT(/10X,30HSYM5PT ERROR -- NGRIDY .LT. 3 ) C STOP C 260 WRITE(NOUT,270) N,MXNEQ 270 FORMAT(/10X,17HN .GT. MXNEQ, N =,I10,8H MXNEQ =,I10) STOP C END SUBROUTINE PNT2D(PCX,PCY,IJ,IX,JY,LNGTHX,HN,HS,HW,HE, PNT20010 A B,NELS,IA,JA,A,IWKSP) C REAL CVALUS(7),BVALUS(4),A(NELS) INTEGER IA(1),JA(NELS),BCTYPE(4),IWKSP(NELS) C C ... SYM5PT / SYM7PT COMMON BLOCKS C COMMON /TBK11/ AX, AY, BX, BY, SRELPR, HX, HY COMMON /TBK12/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,N C C C ... INITIALIZE COEFFICIENTS C CEAST = 0.E0 CWEST = 0.E0 CNORTH = 0.E0 CSOUTH = 0.E0 CALL PDE1(PCX,PCY,CVALUS) CENTER = -CVALUS(6)*(HN+HS)*(HE+HW)/4.E0 CRHS = -CVALUS(7)*(HN+HS)*(HE+HW)/4.E0 C C SET EAST COEFFICIENT C CALL PDE1 (PCX+.5E0*HE,PCY,CVALUS) IF (IX .GE. NGRIDX-1) TEMP = BCOND1(1,BX,PCY,BVALUS) IF (IX .EQ. NGRIDX) GO TO 20 IF ((IX+1 .EQ. NGRIDX) .AND. (BCTYPE(1) .EQ. 1)) GO TO 10 C C NORMAL EAST POINT C CEAST = -CVALUS(1)*(HN+HS)/(2.E0*HE) CENTER = CENTER - CEAST GO TO 30 C C EAST POINT IS A DIRICHLET POINT C 10 TEMP = CVALUS(1)*(HN+HS)/(2.E0*HE) CRHS = CRHS + BVALUS(4)*TEMP/BVALUS(1) CENTER = CENTER + TEMP GO TO 30 C C CENTER POINT LIES ON THE EAST BOUNDARY WHICH IS MIXED C 20 TEMP = CVALUS(1)*(HN+HS)/(2.E0*BVALUS(2)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(4)*TEMP C C SET WEST COEFFICIENT C 30 CALL PDE1(PCX - .5E0*HW,PCY,CVALUS) IF (IX .LE. 2) TEMP = BCOND1(3,AX,PCY,BVALUS) IF (IX .EQ. 1) GO TO 50 IF (IX .EQ. 2 .AND. BCTYPE(3).EQ.1) GO TO 40 C C NORMAL WEST POINT C CWEST = -CVALUS(1)*(HN+HS)/(2.E0*HW) CENTER = CENTER - CWEST GO TO 60 C C WEST POINT IS DIRICHLET C 40 TEMP = CVALUS(1)*(HN+HS)/(2.E0*HW) CRHS = CRHS + BVALUS(4)*TEMP/BVALUS(1) CENTER = CENTER + TEMP GO TO 60 C C CENTER POINT LIES ON WEST BOUNDARY WHICH IS MIXED. C 50 TEMP = CVALUS(1)*(HN + HS)/(2.E0*BVALUS(2)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(4)*TEMP C C SET NORTH COEFFICIENTS C 60 CALL PDE1(PCX,PCY+.5E0*HN,CVALUS) IF (JY .GE. NGRIDY-1) TEMP = BCOND1(4,PCX,BY,BVALUS) IF (JY .EQ. NGRIDY) GO TO 80 IF ((JY.EQ.NGRIDY-1) .AND. BCTYPE(4).EQ.1) GO TO 70 C C NORMAL NORTH POINT C CNORTH = -CVALUS(3) * (HE + HW)/(2.E0*HN) CENTER = CENTER - CNORTH GO TO 90 C C NORTH POINT IS DIRICHLET C 70 TEMP = CVALUS(3) * (HE + HW) / (2.E0*HN) CRHS = CRHS + BVALUS(4)*TEMP / BVALUS(1) CENTER = CENTER + TEMP GO TO 90 C C CENTER POINT LIES ON NORTHERN MIXED BOUNDARY C 80 TEMP = CVALUS(3)*(HE + HW)/(2.E0*BVALUS(3)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(4) * TEMP C C SET SOUTH COEFFICIENTS C 90 CALL PDE1(PCX,PCY-.5E0*HS,CVALUS) IF (JY .LE. 2) TEMP = BCOND1(2,PCX,AY,BVALUS) IF (JY .EQ. 1) GO TO 110 IF (JY .EQ. 2 .AND. BCTYPE(2) .EQ. 1) GO TO 100 C C NORMAL SOUTH POINT C CSOUTH = - CVALUS(3)*(HE+HW)/(2.E0*HS) CENTER = CENTER - CSOUTH GO TO 120 C C SOUTH POINT IS DIRICHLET C 100 TEMP = CVALUS(3) * (HE + HW) / (2.E0 * HS) CRHS = CRHS + BVALUS(4)*TEMP/BVALUS(1) CENTER = CENTER + TEMP GO TO 120 C C CENTER POINT LIES ON SOUTHERN MIXED BOUNDARY C 110 TEMP = CVALUS(3)*(HE+HW)/(2.E0*BVALUS(3)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(4)*TEMP C C COEFFICIENT GENERATION IS COMPLETED. C NOW SET B (RHS) AND IA,JA, AND A (MATRIX REPRESENTATION) C 120 B = CRHS C IF (ILEVEL .EQ. 1) WRITE(NOUT,130) IJ,CRHS 130 FORMAT(/10X,18HSYM5PT -- EQUATION,I8 /20X, A 24HRIGHT HAND SIDE = ,E15.7) C CALL STVAL1(NELS,IA,JA,A,IJ,IJ,CENTER,IWKSP) CALL STVAL1(NELS,IA,JA,A,IJ,IJ+1,CEAST,IWKSP) CALL STVAL1(NELS,IA,JA,A,IJ,IJ-LNGTHX,CSOUTH,IWKSP) CALL STVAL1(NELS,IA,JA,A,IJ,IJ-1,CWEST,IWKSP) CALL STVAL1(NELS,IA,JA,A,IJ,IJ+LNGTHX,CNORTH,IWKSP) C RETURN END SUBROUTINE STVAL1(NELS,IA,JA,A,I,J,VAL,IWKSP) STVA0010 REAL A(NELS) INTEGER IA(1),JA(NELS),IWKSP(NELS),BCTYPE(4) C COMMON /TBK11/ AX, AY, BX, BY, SRELPR, HX, HY COMMON /TBK12/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,N C IF (J .GT. N .OR. VAL .EQ. 0.E0) RETURN IF(ISYM .EQ. 1) GO TO 10 IF(J .LT. I) RETURN C 10 IF (ILEVEL .EQ. 1) WRITE(NOUT,20) J, VAL 20 FORMAT(20X,6HCOLUMN,I8,10H VALUE =,E15.7) C IER = 0 CALL SBSIJ(N,NELS,IA,JA,A,IWKSP,I,J,VAL,0,ILEVEL,NOUT,IER) IF(IER .GT. 700) STOP C RETURN END SUBROUTINE TEST2(EPSI) TEST0010 C C ... TEST2 IS A PROGRAM DESIGNED TO TEST ITPACK 2C METHODS ON C ... MATRICES ARISING FROM THE SYMMETRIC SEVEN POINT DISCRETIZATION C ... OF THREE DIMENSIONAL ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS ON C ... A 3D RECTANGLE WITH A RECTANGULAR MESH. ALL SEVEN METHODS FROM C ... ITPACK 2C ARE TESTED AND A SUMMARY IS PRINTED AT THE END. C C THE EXACT SIZE OF THE TEST PROBLEMS CAN BE INCREASED OR C DECREASED BY CHANGING ARRAY SIZE IN THE DIMENSION STATEMENTS C AND THE VARIABLES LISTED BELOW UNDER SIZE OF TEST PROBLEM. C ALSO, THE NUMBER OF TIMES THROUGH THE TEST LOOPS CAN BE REDUCED C BY CHANGING ITEST AND JTEST AS FOLLOWS. C C ITEST = 1 FOR SYMMETRIC STORAGE TEST C = 2 FOR SYMMETRIC AND NONSYMMETRIC STORAGE TEST C JTEST = 1 FOR NATURAL ORDERING TEST C = 2 FOR NATURAL AND RED-BLACK ORDERING TEST C C ... SYM7PT COMMON BLOCKS C COMMON /TBK21/ AX, AY, AZ, BX, BY, BZ, SRELPR, HX, HY, HZ COMMON /TBK22/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,NGRIDZ,N C C ARRAY DIMENSIONING C REAL GRIDX(7), GRIDY(7), GRIDZ(7), RHS(216), U(216), A(1296), A WKSP(1600), RPARM(12), DIGIT1(7), DIGIT2(7), B TIM1(7), TIM2(7) INTEGER BCTYPE(6), IPARM(12), ITER(7), IWRK(7), IWORK(1296), A IA(217), JA(1296), IWKSP(648) C C C C ... INITIALIZE INTEGER CONSTANTS WHICH CONTROL OUTPUT AND DEFINE C ... ARRAY DIMENSION. THEY ARE C C SRELPR - MACHINE PRECISION C NOUT - FORTRAN OUTPUT UNIT C LEVEL - LEVEL OF OUTPUT FROM ITPACK 2C C IERAN - ERROR ANALYSIS SWITCH C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C ZETA - STOPPING CRITERION C NW - SIZE OF THE REAL ARRAY WKSP. C C ILEVEL - 0/1 LEVEL OF OUTPUT FROM SYM7PT C MXNEQ - MAXIMUM NUMBER OF EQUATIONS TO BE GENERATED (I.E. C THE MAXIMUM NUMBER OF INTERIOR AND NON-DIRICHLET C BOUNDARY POINTS) C NELMAX - MAXIMUM NUMBER OF NON-ZERO ENTRIES IN THE UPPER C TRIANGULAR PART OF THE RESULTING SYMMETRIC MATRIX C NGRIDX - NUMBER OF HORIZONTAL MESH PLANES. C NGRIDY - NUMBER OF VERTICAL MESH PLANES. C NGRIDZ - NUMBER OF PERPENDICULAR MESH PLANES. C NGRDXD - MAXIMUM NUMBER OF VERTICAL MESH PLANES INCLUDING THE C VERTICAL BOUNDARY PLANES. C NGRDYD - MAXIMUM NUMBER OF HORIZONTAL MESH PLANES INCLUDING C THE HORIZONTAL BOUNDARY PLANES. C NGRDZD - MAXIMUM NUMBER OF PERPENDICULAR MESH PLANES INCLUDIN C THE PERPENDICULAR BOUNDARY PLANES. C SRELPR = EPSI C C SET ITPACK SWITCHES C NOUT = 6 LEVEL = 1 IERAN = 0 ITMAX = 75 ZETA = 0.5E-5 NW = 1600 C C C SET NUMBER OF TIMES THROUGH LOOPS C ITEST = 2 JTEST = 2 C SET SIZE OF TEST PROBLEM C ILEVEL = 0 MXNEQ = 216 NELMAX = 1296 NGRIDX = 7 NGRIDY = 7 NGRIDZ = 7 C NGRDXD = NGRIDX NGRDYD = NGRIDY NGRDZD = NGRIDZ WRITE(NOUT,10) 10 FORMAT(1H1 //15X,32HITPACK 2C TEST PROGRAM -- TEST2 A /15X,23HTESTS ITERATIVE MODULES B /15X,41HUSES SEVEN POINT SYMMETRIC DISCRETIZATION ) C C ... SET UP DEFAULT VALUES FOR BCTYPE AND INITIALIZE INFORMATION ARRAYS C C ... BCTYPE DEFINES THE BOUNDARY CONDITIONS ON THE EDGES OF THE C ... RECTANGLE. WHERE C BCTYPE(I) = 0 IMPLIES THE ITH SIDE IS NEUMANN OR MIXED C = 1 IMPLIES THE ITH SIDE IS DIRICHLET C C AND I = 1 IMPLIES THE EAST SIDE DEFINED BY (BX, Y, Z) C = 2 IMPLIES THE SOUTH SIDE DEFINED BY ( X,AY, Z) C = 3 IMPLIES THE WEST SIDE DEFINED BY (AX, Y, Z) C = 4 IMPLIES THE NORTH SIDE DEFINED BY ( X,BY, Z) C = 5 IMPLIES THE TOP SIDE DEFINED BY ( X, Y,BZ) C = 6 IMPLIES THE BOTTOM SIDE DEFINED BY ( X, Y,AZ) C DO 20 I = 1,6 BCTYPE(I) = 1 20 CONTINUE C C ... DEFINE THE DISCRETIZATION MESH C C AX - MINIMUM X VALUE ON THE RECTANGLE (WEST SIDE) C BX - MAXIMUM X VALUE ON THE RECTANGLE (EAST SIDE) C GRIDX - REAL ARRAY CONTAINING THE X-COORDINATE OF THE C HORIZONTAL MESH PLANES FROM WEST TO EAST. C THESE ARE UNIFORM BUT THAT IS NOT REQUIRED. C AY - MINIMUM Y VALUE ON THE RECTANGLE (SOUTH SIDE) C BY - MAXIMUM Y VALUE ON THE RECTANGLE (NORTH SIDE) C GRIDY - REAL ARRAY CONTAINING THE Y-COORDINATE OF THE C VERTICAL MESH PLANES FROM SOUTH TO NORTH. C THESE ARE UNIFORM BUT THAT IS NOT REQUIRED. C AZ - MINIMUM Z VALUE ON THE RECTANGLE (BOTTOM SIDE) C BZ - MAXIMUM Z VALUE ON THE RECTANGLE (TOP SIDE) C GRIDZ - REAL ARRAY CONTAINING THE Z-COORDINATE OF THE C PERPENDICULAR MESH PLANES FROM BOTTOM TO TOP. C THESE ARE UNIFORM BUT THAT IS NOT REQUIRED. C AX = 0.E0 BX = 1.E0 HX = (BX-AX)/ FLOAT(NGRIDX-1) DO 40 J = 1, NGRIDX GRIDX(J) = AX + FLOAT(J-1)*HX 40 CONTINUE GRIDX(NGRIDX) = BX BCTYPE(1) = 2 C AY = 0.E0 BY = 1.E0 HY = (BY-AY)/ FLOAT(NGRIDY-1) DO 50 J = 1, NGRIDY GRIDY(J) = AY + FLOAT(J-1)*HY 50 CONTINUE GRIDY(NGRIDY) = BY BCTYPE(4) = 2 C AZ = 0.E0 BZ = 1.E0 HZ = (BZ-AZ)/ FLOAT(NGRIDZ-1) DO 60 J = 1, NGRIDZ GRIDZ(J) = AZ + FLOAT(J-1)*HZ 60 CONTINUE GRIDZ(NGRIDZ) = BZ BCTYPE(5) = 2 C C ... DISCRETIZE THE ELLIPTIC PDE C DO 70 LOOP1=1,ITEST ISYM = LOOP1 - 1 IF(LOOP1 .EQ. 2) WRITE(NOUT,63) 63 FORMAT(1H1///) CALL SYM7PT(GRIDX,NGRDXD,GRIDY,NGRDYD,GRIDZ,NGRDZD, A RHS,MXNEQ,IA,JA,A,NELMAX,IWORK) C C C ... SOLVE THE MATRIX PROBLEM C C DO 70 LOOP2=1,JTEST NB = LOOP2 - 2 IF(ISYM .EQ. 0) WRITE(NOUT,91) IF(ISYM .EQ. 1) WRITE(NOUT,92) IF(NB .EQ. (-1)) WRITE(NOUT,93) IF(NB .EQ. 0) WRITE(NOUT,94) C C TEST JCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL JCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(1)=RPARM(9) TIM2(1)=RPARM(10) DIGIT1(1)=RPARM(11) DIGIT2(1)=RPARM(12) ITER(1)=IPARM(1) IWRK(1)=IPARM(8) C C TEST JSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL JSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(2)=RPARM(9) TIM2(2)=RPARM(10) DIGIT1(2)=RPARM(11) DIGIT2(2)=RPARM(12) ITER(2)=IPARM(1) IWRK(2)=IPARM(8) C C TEST SOR C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SOR (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(3)=RPARM(9) TIM2(3)=RPARM(10) DIGIT1(3)=RPARM(11) DIGIT2(3)=RPARM(12) ITER(3)=IPARM(1) IWRK(3)=IPARM(8) C C TEST SSORCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SSORCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(4)=RPARM(9) TIM2(4)=RPARM(10) DIGIT1(4)=RPARM(11) DIGIT2(4)=RPARM(12) ITER(4)=IPARM(1) IWRK(4)=IPARM(8) C C TEST SSORSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(9)=NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SSORSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(5)=RPARM(9) TIM2(5)=RPARM(10) DIGIT1(5)=RPARM(11) DIGIT2(5)=RPARM(12) ITER(5)=IPARM(1) IWRK(5)=IPARM(8) C C TEST RSCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL RSCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(6)=RPARM(9) TIM2(6)=RPARM(10) DIGIT1(6)=RPARM(11) DIGIT2(6)=RPARM(12) ITER(6)=IPARM(1) IWRK(6)=IPARM(8) C C TEST RSSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL RSSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(7)=RPARM(9) TIM2(7)=RPARM(10) DIGIT1(7)=RPARM(11) DIGIT2(7)=RPARM(12) ITER(7)=IPARM(1) IWRK(7)=IPARM(8) C C TIMING ANALYSIS C CALL TIME1 (N,IA,JA,A,WKSP,WKSP(N+1),ITER,TIM1,TIM2, A DIGIT1,DIGIT2,IWRK,NOUT) 70 CONTINUE C 91 FORMAT(//15X,29HSYMMETRIC SPARSE STORAGE USED ) 92 FORMAT(//15X,32HNONSYMMETRIC SPARSE STORAGE USED ) 93 FORMAT(15X,21HNATURAL ORDERING USED ) 94 FORMAT(15X,23HRED-BLACK ORDERING USED ) RETURN END SUBROUTINE PDE2(X,Y,Z,CVALUS) PDE20010 C C ... THIS SUBROUTINE IS A USER SUPPLIED SUBROUTINE TO SPECIFY THE C ... SELF-ADJOINT ELLIPTIC PDE FOR SYM7PT IN THE FOLLOWING FORM C C (CVALUS(1)*UX)X + (CVALUS(3)*UY)Y + (CVALUS(6)*UZ)Z C + CVALUS(10)*U = CVALUS(11) C C NOTE: CVALUS(I), FOR I = 2, 4, 5, 7, 8, AND 9 ARE NOT USED. C REAL CVALUS(11) C CVALUS( 1) = 1.E0 CVALUS( 2) = 0.E0 CVALUS( 3) = 2.E0 CVALUS( 4) = 0.E0 CVALUS( 5) = 0.E0 CVALUS( 6) = 1.E0 CVALUS( 7) = 0.E0 CVALUS( 8) = 0.E0 CVALUS( 9) = 0.E0 CVALUS(10) = 0.E0 CVALUS(11) = 0.E0 C RETURN END REAL FUNCTION BCOND2(ISIDE,X,Y,Z,BVALUS) BCON0010 C C ... THIS REAL FUNCTION IS A USER SUPPLIED FUNCTION TO SPECIFY THE C ... BOUNDARY CONDITIONS OF THE ELLIPTIC PDE DEPENDING ON ISIDE, X, C ... Y, AND Z. C C IF ISIDE = 1, THEN X = BX (EAST SIDE) C = 2, THEN Y = AY (SOUTH SIDE) C = 3, THEN X = AX (WEST SIDE) C = 4, THEN Y = BY (NORTH SIDE) C = 5, THEN Z = BZ (TOP SIDE) C = 6, THEN Z = AZ (BOTTOM SIDE) C C ... THE BVALUS ARRAY IS DEFINED AS FOLLOWS C C BVALUS(1)*U + BVALUS(2)*UX + BVALUS(3)*UY + BVALUS(4)*UZ C = BVALUS(5) C C NOTE: BCOND2 IS SET TO BVALUS(5) BEFORE RETURNING. C REAL BVALUS(5) C GOTO(10,20,30,40,50,60),ISIDE C 10 BVALUS(2) = 1.E0 BVALUS(1) = 0.E0 BVALUS(5) = Y*Z*(1.E0 + Y*Z) BVALUS(3) = 0.E0 BVALUS(4) = 0.E0 GO TO 999 C 20 BVALUS(1) = 1.E0 BVALUS(5) = 1.E0 BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 BVALUS(4) = 0.E0 GO TO 999 C 30 BVALUS(1) = 1.E0 BVALUS(5) = 1.E0 BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 BVALUS(4) = 0.E0 GO TO 999 C 40 BVALUS(3) = 1.E0 BVALUS(1) = 0.E0 BVALUS(2) = 0.E0 BVALUS(5) = X*Z * (1.E0+ X*Z) BVALUS(4) = 0.E0 GO TO 999 C 50 BVALUS(4) = 1.E0 BVALUS(1) = 0.E0 BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 BVALUS(5) = X*Y * (1.E0+ X*Y) GO TO 999 C 60 BVALUS(1) = 1.E0 BVALUS(5) = 1.E0 BVALUS(2) = 0.E0 BVALUS(3) = 0.E0 BVALUS(4) = 0.E0 C 999 CONTINUE BCOND2 = BVALUS(5) RETURN END SUBROUTINE SYM7PT (GRIDX,NGRDXD,GRIDY,NGRDYD,GRIDZ,NGRDZD,RHS, SYM70010 A MXNEQ,IA,JA,A,NELS,IWKSP) C INTEGER IA(1), JA(NELS), BCTYPE(6), IWKSP(NELS) REAL GRIDX(NGRDXD),GRIDY(NGRDYD),GRIDZ(NGRDZD), A RHS(MXNEQ),A(NELS) C C ... SYM7PT COMMON BLOCKS C COMMON /TBK21/ AX, AY, AZ, BX, BY, BZ, SRELPR, HX, HY, HZ COMMON /TBK22/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,NGRIDZ,N C C IF (NGRIDX.LT.3 .OR. NGRIDY.LT.3 .OR. NGRIDZ.LT.3) GO TO 120 C C DETERMINE RANGE OF UNKNOWN GRID POINTS C IX1 = 1 IX2 = NGRIDX JY1 = 1 JY2 = NGRIDY KZ1 = 1 KZ2 = NGRIDZ IF (BCTYPE(1) .EQ. 1) IX2 = NGRIDX - 1 IF (BCTYPE(2) .EQ. 1) JY1 = 2 IF (BCTYPE(3) .EQ. 1) IX1 = 2 IF (BCTYPE(4) .EQ. 1) JY2 = NGRIDY - 1 IF (BCTYPE(6) .EQ. 1) KZ1 = 2 IF (BCTYPE(5) .EQ. 1) KZ2 = NGRIDZ - 1 LNGTHX = IX2 - IX1 + 1 LNGTHY = JY2 - JY1 + 1 N = LNGTHX * LNGTHY * (KZ2 - KZ1 + 1) IF (N .GT. MXNEQ) GO TO 260 C C OUTPUT INITIAL GRID INFORMATION C IF (ILEVEL .EQ. 0) GO TO 70 WRITE(NOUT,20) AX,BX,AY,BY,AZ,BZ 20 FORMAT(//10X,24HFINITE DIFFERENCE MODULE ,6H ---- , A 21HSYMMETRIC SEVEN POINT //10X,15HDOMAIN = BOX (, B E11.4,1H,,E11.4,5H) X (,E11.4,1H,,E11.4,5H) X (,E11.4,1H,, C E11.4,1H) ) C WRITE(NOUT,30) 30 FORMAT(/10X,28HCOEFFICIENTS OF X-MESH LINES ) WRITE(NOUT,40) (GRIDX(I),I=1,NGRIDX) 40 FORMAT(/8X,8(2X,E11.4) ) WRITE(NOUT,50) 50 FORMAT(/10X,28HCOEFFICIENTS OF Y-MESH LINES ) WRITE(NOUT,40) (GRIDY(I),I=1,NGRIDY) WRITE(NOUT,55) 55 FORMAT(/10X,28HCOEFFICIENTS OF Z-MESH LINES ) WRITE(NOUT,40) (GRIDZ(I),I=1,NGRIDZ) WRITE(NOUT,60) (BCTYPE(I), I=1,6) 60 FORMAT(/10X,46HBOUNDARY CONDITIONS ON PIECES 1,2,3,4,5,6 ARE , A 5(1X,I1,1H,),1X,I1,1H. //) C C GENERATE EQUATIONS ONE MESH POINT AT A TIME C 70 CONTINUE CALL SBINI(N,NELS,IA,JA,A,IWKSP) C DO 100 IJ = 1,N IXX = MOD(IJ-1,LNGTHX) + 1 JYY = MOD((IJ-IXX)/LNGTHX,LNGTHY) + 1 KZZ = (IJ-IXX-(JYY-1)*LNGTHX)/(LNGTHX*LNGTHY) + 1 IXX = IXX + IX1 - 1 JYY = JYY + JY1 - 1 KZZ = KZZ + KZ1 - 1 C HU = 0.E0 HD = 0.E0 HW = 0.E0 HE = 0.E0 HS = 0.E0 HN = 0.E0 PZ = GRIDZ(KZZ) IF (KZZ .NE. 1) HD = PZ - GRIDZ(KZZ-1) IF (KZZ .NE. NGRIDZ) HU = GRIDZ(KZZ+1) - PZ PY = GRIDY(JYY) IF (JYY .NE. 1) HS = PY - GRIDY(JYY-1) IF (JYY .NE. NGRIDY) HN = GRIDY(JYY+1) - PY PX = GRIDX(IXX) IF (IXX .NE. 1) HW = PX - GRIDX(IXX-1) IF (IXX .NE. NGRIDX) HE = GRIDX(IXX+1) - PX C IJIN = IJ CALL PNT3D(PX,PY,PZ,IJIN,IXX,JYY,KZZ,LNGTHX,LNGTHY, A HN,HS,HW,HE,HU,HD,B,NELS,IA,JA,A,IWKSP) C RHS(IJ) = B 100 CONTINUE CALL SBEND(N,NELS,IA,JA,A,IWKSP) C C NORMAL EXIT C IF (ILEVEL .EQ. 0) RETURN C WRITE(NOUT,110) 110 FORMAT(/10X,30HSYM7PT COMPLETED SUCCESSFULLY. ) NU = IA(N+1) - 1 NUU = N + 1 + 2*NU WRITE(NOUT,115) N,NU,NUU 115 FORMAT( 10X,38HSPARSE MATRIX REPRESENTATION FINISHED. A /15X,25HNO. OF EQUATIONS =,I8 B /15X,25HNO. OF NON-ZEROES =,I8 C /15X,25HTOTAL MATRIX STORAGE =,I8 /) C RETURN C C ERROR EXITS C 120 CONTINUE IF (NGRIDX .LT. 3) WRITE(NOUT,160) 160 FORMAT(//20X,30HSYM7PT ERROR -- NGRIDX .LT. 3 ) IF (NGRIDY .LT. 3) WRITE(NOUT,170) 170 FORMAT(//20X,30HSYM7PT ERROR -- NGRIDY .LT. 3 ) IF (NGRIDZ .LT. 3) WRITE(NOUT,180) 180 FORMAT(//20X,30HSYM7PT ERROR -- NGRIDZ .LT. 3 ) C STOP C 260 WRITE(NOUT,270) N,MXNEQ 270 FORMAT(/10X,17HN .GT. MXNEQ, N =,I10,8H MXNEQ =,I10) STOP C END SUBROUTINE PNT3D(PCX,PCY,PCZ,IJ,IX,JY,KZ,LNGTHX,LNGTHY, PNT30010 A HN,HS,HW,HE,HU,HD,B,NELS,IA,JA,A,IWKSP) C INTEGER IA(1), JA(NELS), BCTYPE(6), IWKSP(NELS) REAL CVALUS(11), BVALUS(5), A(NELS) C C ... SYM7PT COMMON BLOCKS C COMMON /TBK21/ AX, AY, AZ, BX, BY, BZ, SRELPR, HX, HY, HZ COMMON /TBK22/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,NGRIDZ,N C C C INITIALIZE COEFFICIENTS C CUP = 0.E0 CLOWER = 0.E0 CEAST = 0.E0 CWEST = 0.E0 CNORTH = 0.E0 CSOUTH = 0.E0 CALL PDE2(PCX,PCY,PCZ,CVALUS) CENTER = -CVALUS(10)*(HN+HS)*(HE+HW)*(HU+HD)/8.E0 CRHS = -CVALUS(11)*(HN+HS)*(HE+HW)*(HU+HD)/8.E0 C C SET EAST COEFFICIENT C CALL PDE2 (PCX+.5E0*HE,PCY,PCZ,CVALUS) IF (IX .GE. NGRIDX-1) TEMP = BCOND2(1,BX,PCY,PCZ,BVALUS) IF (IX .EQ. NGRIDX) GO TO 20 IF ((IX+1 .EQ. NGRIDX) .AND. (BCTYPE(1) .EQ. 1)) GO TO 10 C C NORMAL EAST POINT C CEAST = -CVALUS(1)*(HN+HS)*(HU+HD)/(4.E0*HE) CENTER = CENTER - CEAST GO TO 30 C C EAST POINT IS A DIRICHLET POINT C 10 TEMP = CVALUS(1)*(HN+HS)*(HU+HD)/(4.E0*HE) CRHS = CRHS + BVALUS(5)*TEMP/BVALUS(1) CENTER = CENTER + TEMP GO TO 30 C C CENTER POINT LIES ON THE EAST BOUNDARY WHICH IS MIXED C 20 TEMP = CVALUS(1)*(HN+HS)*(HU+HD)/(4.E0*BVALUS(2)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(5)*TEMP C C SET WEST COEFFICIENT C 30 CALL PDE2(PCX - .5E0*HW,PCY,PCZ,CVALUS) IF (IX .LE. 2) TEMP = BCOND2(3,AX,PCY,PCZ,BVALUS) IF (IX .EQ. 1) GO TO 50 IF (IX .EQ. 2 .AND. BCTYPE(3).EQ.1) GO TO 40 C C NORMAL WEST POINT C CWEST = -CVALUS(1)*(HN+HS)*(HU+HD)/(4.E0*HW) CENTER = CENTER - CWEST GO TO 60 C C WEST POINT IS DIRICHLET C 40 TEMP = CVALUS(1)*(HN+HS)*(HU+HD)/(4.E0*HW) CRHS = CRHS + BVALUS(5)*TEMP/BVALUS(1) CENTER = CENTER + TEMP GO TO 60 C C CENTER POINT LIES ON WEST BOUNDARY WHICH IS MIXED. C 50 TEMP = -CVALUS(1)*(HN+HS)*(HU+HD)/(4.E0*BVALUS(2)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(5)*TEMP C C SET NORTH COEFFICIENTS C 60 CALL PDE2(PCX,PCY+.5E0*HN,PCZ,CVALUS) IF (JY .GE. NGRIDY-1) TEMP = BCOND2(4,PCX,BY,PCZ,BVALUS) IF (JY .EQ. NGRIDY) GO TO 80 IF ((JY.EQ.NGRIDY-1) .AND. BCTYPE(4).EQ.1) GO TO 70 C C NORMAL NORTH POINT C CNORTH = -CVALUS(3) * (HE + HW) * (HU + HD)/(4.E0*HN) CENTER = CENTER - CNORTH GO TO 90 C C NORTH POINT IS DIRICHLET C 70 TEMP = CVALUS(3) * (HE + HW) * (HU + HD) / (4.E0*HN) CRHS = CRHS + BVALUS(5)*TEMP / BVALUS(1) CENTER = CENTER + TEMP GO TO 90 C C CENTER POINT LIES ON NORTHERN MIXED BOUNDARY C 80 TEMP = CVALUS(3)*(HE + HW) * (HU + HD)/(4.E0*BVALUS(3)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(5) * TEMP C C SET SOUTH COEFFICIENTS C 90 CALL PDE2(PCX,PCY-.5E0*HS,PCZ,CVALUS) IF (JY .LE. 2) TEMP = BCOND2(2,PCX,AY,PCZ,BVALUS) IF (JY .EQ. 1) GO TO 110 IF (JY .EQ. 2 .AND. BCTYPE(2) .EQ. 1) GO TO 100 C C NORMAL SOUTH POINT C CSOUTH = - CVALUS(3)*(HE+HW) * (HU + HD)/(4.E0*HS) CENTER = CENTER - CSOUTH GO TO 120 C C SOUTH POINT IS DIRICHLET C 100 TEMP = CVALUS(3) * (HE + HW) * (HU + HD) / (4.E0 * HS) CRHS = CRHS + BVALUS(5)*TEMP/BVALUS(1) CENTER = CENTER + TEMP GO TO 120 C C CENTER POINT LIES ON SOUTHERN MIXED BOUNDARY C 110 TEMP = -CVALUS(3)*(HE+HW) * (HU + HD)/(4.E0*BVALUS(3)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(5)*TEMP C C SET UPPER COEFFICIENTS C 120 CALL PDE2(PCX,PCY,PCZ+.5E0*HU,CVALUS) IF (KZ .GE. NGRIDZ-1) TEMP = BCOND2(5,PCX,PCY,BZ,BVALUS) IF (KZ .EQ. NGRIDZ) GO TO 140 IF ((KZ.EQ.NGRIDZ-1) .AND. BCTYPE(5).EQ.1) GO TO 130 C C NORMAL UPPER POINT C CUP = -CVALUS(6) * (HE + HW) * (HN + HS)/(4.E0*HU) CENTER = CENTER - CUP GO TO 150 C C UPPER POINT IS DIRICHLET C 130 TEMP = CVALUS(6) * (HE + HW) * (HN + HS) / (4.E0*HU) CRHS = CRHS + BVALUS(5)*TEMP / BVALUS(1) CENTER = CENTER + TEMP GO TO 150 C C CENTER POINT LIES ON UPPER MIXED BOUNDARY C 140 TEMP = CVALUS(6)*(HE + HW) * (HN + HS)/(4.E0*BVALUS(4)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(5) * TEMP C C SET LOWER COEFFICIENTS C 150 CALL PDE2(PCX,PCY,PCZ-.5E0*HD,CVALUS) IF (KZ .LE. 2) TEMP = BCOND2(6,PCX,PCY,AZ,BVALUS) IF (KZ .EQ. 1) GO TO 170 IF (KZ .EQ. 2 .AND. BCTYPE(6) .EQ. 1) GO TO 160 C C NORMAL LOWER POINT C CLOWER = - CVALUS(6)*(HE+HW) * (HN + HS)/(4.E0*HD) CENTER = CENTER - CLOWER GO TO 300 C C LOWER POINT IS DIRICHLET C 160 TEMP = CVALUS(6) * (HE + HW) * (HN + HS) / (4.E0*HD) CRHS = CRHS + BVALUS(5)*TEMP/BVALUS(1) CENTER = CENTER + TEMP GO TO 300 C C CENTER POINT LIES ON LOWER MIXED BOUNDARY C 170 TEMP = -CVALUS(6)*(HE+HW) * (HN + HS)/(4.E0*BVALUS(4)) CENTER = CENTER + BVALUS(1)*TEMP CRHS = CRHS + BVALUS(5)*TEMP C C COEFFICIENT GENERATION IS COMPLETED. C NOW SET B (RHS), IA, JA, AND A (MATRIX REPRESENTATION) C 300 B = CRHS C IF (ILEVEL .EQ. 1) WRITE(NOUT,310) IJ, CRHS 310 FORMAT(/10X,18HSYM7PT -- EQUATION,I8 /20X, A 24HRIGHT HAND SIDE = ,E15.7) C LXY = LNGTHX * LNGTHY CALL STVAL2(NELS,IA,JA,A,IJ,IJ ,CENTER,IWKSP) CALL STVAL2(NELS,IA,JA,A,IJ,IJ+1 ,CEAST ,IWKSP) CALL STVAL2(NELS,IA,JA,A,IJ,IJ-1 ,CWEST ,IWKSP) CALL STVAL2(NELS,IA,JA,A,IJ,IJ-LNGTHX,CSOUTH,IWKSP) CALL STVAL2(NELS,IA,JA,A,IJ,IJ+LNGTHX,CNORTH,IWKSP) CALL STVAL2(NELS,IA,JA,A,IJ,IJ-LXY ,CLOWER,IWKSP) CALL STVAL2(NELS,IA,JA,A,IJ,IJ+LXY ,CUP ,IWKSP) C RETURN END SUBROUTINE STVAL2(NELS,IA,JA,A,I,J,VAL,IWKSP) STVA0010 REAL A(NELS) INTEGER IA(1),JA(NELS),IWKSP(NELS),BCTYPE(6) COMMON /TBK21/ AX, AY, AZ, BX, BY, BZ, SRELPR, HX, HY, HZ COMMON /TBK22/ BCTYPE,ILEVEL,ISYM,NOUT,NGRIDX,NGRIDY,NGRIDZ,N C IF (J .GT. N .OR. VAL .EQ. 0.E0) RETURN IF(ISYM .EQ. 1) GO TO 5 IF(J .LT. I) RETURN C 5 IF (ILEVEL .EQ. 1) WRITE(NOUT,20) J, VAL 20 FORMAT(20X,6HCOLUMN,I8,10H VALUE =,E15.7) C IER = 0 CALL SBSIJ(N,NELS,IA,JA,A,IWKSP,I,J,VAL,0,ILEVEL,NOUT,IER) C IF (IER .GT. 700) STOP C RETURN END SUBROUTINE TEST3(EPSI) TEST0010 C C TEST3 EXERCISES ITPACK OVER SPARSE LINEAR SYSTEMS C OF ORDER AT MOST 40 WITH RANDOMLY GENERATED STRUCTURE. C (FOR DETAILS SEE SECTION 2 OF CENTER FOR NUMERICAL ANALYSIS C REPORT CNA-171 BY DAVID R. KINCAID: C ACCELERATION PARAMETERS FOR A SYMMETRIC SUCCESSIVE OVERRELAXATION C CONJUGATE GRADIENT METHOD FOR NONSYMMETRIC SYSTEMS, C CENTER FOR NUMERICAL ANALYSIS, UNIVERSITY OF TEXAS, AUSTIN, TX, C 78712 - ALSO IN ADVANCES IN COMPUTER METHODS FOR PARTIAL C DIFFERENTIAL EQUATIONS, IV, IMACS, NEW BRUNSWICK, NJ, 1981.) C C***************************************************************** C C THE EXACT SIZE OF THE TEST PROBLEMS CAN BE INCREASED OR C DECREASED BY CHANGING THE ARRAY SIZE IN DIMENSION STATEMENTS C AND THE VARIABLES LISTED BELOW UNDER SIZE OF TEST PROBLEM. C C ARRAY DIMENSIONING C INTEGER IA(41),JA(1600),IROW(40),IWKSP(1600),P(40),IP(40) REAL A(1600),RHS(40),ROW(40),WKSP(500) C C TEST3 COMMON BLOCK C COMMON /TBK31/ SRELPR, ZETA COMMON /TBK32/ IDEBUG, IERAN, ILEVEL, IORD, IPCT, IPLT, ISEED, A ISYM, ITMAX, LARGE, LEVEL, MAXNZ, MAXN, NOUT, B NBLACK, NB, NRBN, NRED, NW, NZBLK, NZRED, N C SRELPR = EPSI C C SET ITPACK 2C SWITCHS C C ZETA - STOPPING TEST CRITERION C LEVEL - LEVEL OF OUTPUT FROM ITPACK 2C C ITMAX - MAXIMUM NUMBER OF ITERATIONS ALLOWED C IERAN - ERROR ANALYSIS SWITCH C NOUT - OUTPUT UNIT NUMBER C C ZETA = 1.E-5 LEVEL = 1 ITMAX = 50 IERAN = 0 NOUT = 6 C C PROBLEM SIZE C C MAXNZ - MAXIMUM NUMBER OF NONZEROS C MAXN - MAXIMUM SIZE OF SYSTEM C NW - SIZE OF REAL ARRAY WKSP C N - SIZE OF LINEAR SYSTEM C IPCT - PERCENTAGE OF OFFDIAGONAL NONZEROS C MAXNZ = 1600 MAXN = 40 NW = 500 N = 40 IPCT = 20 C C SWITCHES FOR TESTING PROGRAM C C ILEVEL - 0/1 SWITCH FOR PRINT FROM TESTING PROGRAM C IDEBUG - 0/1 SWITCH FOR DEBUG PRINTING FROM TESTING PROGRAM C IPLT - 0/1 SWITCH FOR PRINTER PLOTTING OF NONZERO STRUCTURE C LARGE - 0/1 SWITCH FOR TESTING ITPACK ROUTINE SBELM C ISEED - RANDUM NUMBER GENERATOR SEED C ILEVEL = 0 IDEBUG = 0 IPLT = 1 LARGE = 1 ISEED = 256 C C OTHER VARIABLES THAT CONTROL NATURE OF TEST C C NRED - NUMBER OF RED EQUATIONS C NBLACK - NUMBER OF BLACK EQUATIONS C NZRED - NUMBER OF RED OFFDIAGONAL NONZERO ENTRIES C NZBLK - NUMBER OF BLACK OFFDIAGONAL NONZERO ENTRIES C NRNB - SIZE OF RED/BLACK BLOCK (NRED*NBLACK) C ISYM - 0/1 SWITCH FOR SYMMETRIC/NONSYMMETRIC STORAGE C NB - ORDER OF BLACK SUBSYSTEM C IORD - 1/2 SWITCH FOR NATURAL/RED-BLACK ORDERING C C WRITE(NOUT,6000) 6000 FORMAT(1H1 //15X,32HITPACK 2C TEST PROGRAM -- TEST3 // ) C C GENERATE RANDOM NUMBERS FOR N, NRED, NZRED, P C CALL SETPER ( P, IP ) C WRITE(NOUT,7010) N,IPCT,NRED,NZRED 7010 FORMAT(//2X,70(1H*) A /5X,33HORDER OF SYSTEM =, I5 A /5X,33HPERCENTAGE OFFDIAGONAL NONZEROS =, I5 B /5X,33HINITIAL NUMBER OF RED POINTS =, I5 C /5X,33HNUMBER OF RED NONZERO ENTRIES =, I5 /) C C ...... LOOP FOR SYMMETRIC AND NONSYMMETRIC SYSTEMS OF SAME SIZE C DO 100 LOOP = 1,2 ISYM = LOOP -1 C C ...... GENERATE RANDOM SPARSE SYSTEM C CALL SETSYS(IA,JA,A,RHS,P,IP,ROW,IROW,IWKSP) C IF(ISYM .EQ. 0) WRITE(NOUT,41) IF(ISYM .NE. 0) WRITE(NOUT,42) WRITE(NOUT,45) 41 FORMAT(1H0,14X,22HSYMMETRIC SYSTEM USING) 42 FORMAT(1H0,14X,25HNONSYMMETRIC SYSTEM USING) 45 FORMAT(15X,16HNATURAL ORDERING) 46 FORMAT(15X,18HRED-BLACK ORDERING) C C ...... TEST ITPACK 2C ROUTINES: NATURAL ORDERING C IORD = 1 CALL TSTITP(IA,JA,A,RHS,ROW,IWKSP,WKSP) C C ...... TEST RED-BLACK SYSTEM C CALL TSTPRB(IA,JA,A,RHS,P,IP,IROW,IWKSP) C IF(ISYM .EQ. 0) WRITE(NOUT,41) IF(ISYM .NE. 0) WRITE(NOUT,42) WRITE(NOUT,46) C C ...... TEST ITPACK 2C ROUTINES: RED-BLACK ORDERING C IORD = 2 CALL TSTITP(IA,JA,A,RHS,ROW,IWKSP,WKSP) C 100 CONTINUE C RETURN END SUBROUTINE SETPER ( P, IP ) SETP0010 C C C GENERATE RANDOM NUMBERS FOR C ORDER OF SYSTEM, RED POINTS, NONZERO POINTS, PERMUTATION C C INTEGER P(1), IP(1) C COMMON /TBK31/ SRELPR, ZETA COMMON /TBK32/ IDEBUG, IERAN, ILEVEL, IORD, IPCT, IPLT, ISEED, A ISYM, ITMAX, LARGE, LEVEL, MAXNZ, MAXN, NOUT, B NBLACK, NB, NRBN, NRED, NW, NZBLK, NZRED, N C NRED = N/2 NBLACK = N - NRED NRNB = NRED*NBLACK C C COMPUTE NUMBER OF NONZEROS RED ENTRIES C NZRED = IFIX(FLOAT(NRNB)*FLOAT(IPCT)*1.0E-2) NZBLK = NZRED C C GENERATE RANDOM PERMUTATION C DO 10 I = 1, N P(I) = I IP(I) = IRAND ( 1, N , ISEED ) 10 CONTINUE C RETURN END SUBROUTINE SETSYS (IA,JA,A,RHS,P,IP,ROW,IROW,IWKSP) SETS0010 C C GENERATE SPARSE SYSTEM WITH RANDOM STRUCTURE C INTEGER IA(1),JA(1),P(1),IP(1),IWKSP(1),IROW(1),PI,PJ REAL A(1),RHS(1),ROW(1) C COMMON /TBK31/ SRELPR, ZETA COMMON /TBK32/ IDEBUG, IERAN, ILEVEL, IORD, IPCT, IPLT, ISEED, A ISYM, ITMAX, LARGE, LEVEL, MAXNZ, MAXN, NOUT, B NBLACK, NB, NRBN, NRED, NW, NZBLK, NZRED, N C DO 2 I=1,N 2 ROW(I) = FLOAT(P(I)) CALL QSORT(N,IP,ROW,IER) DO 3 I=1,N 3 P(I) = IFIX(ROW(I)) IF(IER .EQ. 0) GO TO 5 C WRITE(NOUT, 20) IER 20 FORMAT(/2X,18HQSORT ERROR, IER =, I5 ) STOP C C C 5 CALL SBINI ( N, MAXNZ, IA, JA, A, IWKSP ) C C ZERO OUT THINGS , SET RHS TO 1.0 C DO 15 K = 1, N RHS(K) = 1.E0 ROW(K) = 0.E0 15 CONTINUE C IF ( ISYM .NE. 0 ) GO TO 51 C C ******************* SYMMETRIC STORAGE CASE ********************** WRITE(NOUT,6001) 6001 FORMAT(/2X,20(1H+),24HSYMMETRIC STORAGE FORMAT ,20(1H+) ) C C STORE SYMMETRIC SYSTEM OFF-DIAGONAL ELEMENTS C DO 50 K = 1, NZRED 501 I = IRAND ( 1, NRED, ISEED ) J = IRAND ( NRED+1, N, ISEED ) PI = MIN0 ( P(I), P(J) ) PJ = MAX0 ( P(I), P(J) ) VAL = - RANDOM(ISEED) IF(IDEBUG .NE. 0) WRITE(NOUT,6002) PI,PJ,VAL 6002 FORMAT(/2X,17H NONZERO ENTRY ( ,I10,3H , ,I10,9H ) SET = ,G15.8) CALL SBSIJ ( N, MAXNZ, IA, JA, A, IWKSP, PI, PJ, VAL, -1, A ILEVEL, NOUT, IER) IF ( IER .EQ. 700 ) GO TO 501 IF ( IER .GT. 700 ) STOP ROW(PI) = ROW(PI) - VAL ROW(PJ) = ROW(PJ) - VAL 50 CONTINUE GO TO 57 C C ******************* NONSYMMETRIC STORAGE CASE ****************** C 51 WRITE(NOUT,6003) 6003 FORMAT(/2X,20(1H+),27HNONSYMMETRIC STORAGE FORMAT ,20(1H+) ) C C STORE NONSYMMETRIC SYSTEM OFF-DIAGONAL ELEMENTS C DO 505 K = 1, NZRED 506 I = IRAND ( 1, NRED, ISEED) J = IRAND ( NRED+1, N, ISEED ) PI = P(I) PJ = P(J) VAL = - RANDOM(ISEED) IF(IDEBUG .NE. 0) WRITE(NOUT,6002) PI,PJ,VAL CALL SBSIJ ( N, MAXNZ, IA, JA, A, IWKSP, PI, PJ, VAL, -1, A ILEVEL, NOUT, IER) IF ( IER .EQ. 700 ) GO TO 506 IF ( IER .GT. 700 ) STOP ROW(PI) = ROW(PI) - VAL 505 CONTINUE DO 56 K = 1, NZBLK 507 I = IRAND ( NRED+1, N, ISEED ) J = IRAND ( 1, NRED, ISEED ) PI = P(I) PJ = P(J) VAL = - RANDOM(ISEED) IF(IDEBUG .NE. 0) WRITE(NOUT,6002) PI,PJ,VAL CALL SBSIJ ( N, MAXNZ, IA, JA, A, IWKSP, PI, PJ, VAL, -1, A ILEVEL, NOUT, IER) IF ( IER .EQ. 700 ) GO TO 507 IF ( IER .GT. 700) STOP ROW(PI) = ROW(PI) - VAL 56 CONTINUE C C **************************************************************** C C SET DIAGONAL C 57 CONTINUE DO 40 K = 1, N VAL = ROW(K) + 1.E0 PI = K PJ = K IF(IDEBUG .NE. 0) WRITE(NOUT,6002) PI,PJ,VAL CALL SBSIJ ( N, MAXNZ, IA, JA, A, IWKSP, PI, PJ, VAL, 0, A ILEVEL, NOUT, IER) IF ( IER .GT. 700 ) STOP 40 CONTINUE CALL SBEND(N,MAXNZ,IA,JA,A,IWKSP) IF(IDEBUG .EQ. 0) GO TO 4441 CALL SYSOUT(N,NZRED,NZBLK,IA,JA,A,RHS,NOUT,ISYM) 4441 CONTINUE C C SET SOME DIAGONAL ELEMENTS VERY LARGE C IF(LARGE .EQ. 0) GO TO 5553 EVAL = 1.E8 CALL SBAGN(N,MAXNZ,IA,JA,A,IWKSP,ILEVEL,NOUT,IER) IF(IER .NE. 0) STOP C DO 43 K=1,N,5 NBIG = IRAND(1,N,ISEED) RHS(NBIG) = EVAL + RHS(NBIG) PI = NBIG PJ = NBIG IF(IDEBUG .NE. 0) WRITE(NOUT,6002) PI,PJ,VAL CALL SBSIJ(N,MAXNZ,IA,JA,A,IWKSP,PI,PJ,EVAL,1, A ILEVEL, NOUT, IER) IF(IER .GT. 700) STOP 43 CONTINUE CALL SBEND(N,MAXNZ,IA,JA,A,IWKSP) C IF(IDEBUG .EQ. 0) GO TO 5553 CALL SYSOUT(N,NZRED,NZBLK,IA,JA,A,RHS,NOUT,ISYM) C C ...... TEST ROUTINE TO REMOVE ROWS AND COLUMNS C 5553 CONTINUE TOL = 1.E-8 CALL SBELM(N,IA,JA,A,RHS,IROW,ROW,TOL,ISYM,ILEVEL,NOUT,IER) IF(IER .NE. 0) STOP IF(IDEBUG .EQ. 0) GO TO 4442 CALL SYSOUT(N,NZRED,NZBLK,IA,JA,A,RHS,NOUT,ISYM) 4442 CONTINUE C C ...... SYSTEM SET-UP C IF(IPLT .EQ. 0) GO TO 899 WRITE(NOUT,6015) 6015 FORMAT(1H1/2X,45HPATTERN OF NONZEROS WITH NATURAL ORDERING /) CALL PLTADJ ( N, IA, JA, ISYM, IROW, IWKSP, NOUT ) 899 IF ( IDEBUG .EQ. 0 ) RETURN C C DEBUGGING PRINT OUT C WRITE(NOUT,900) 900 FORMAT(//2X,14HDEBUG PRINTING A ,2X,34HP ARRAY BEFORE RED-BLACK INDEXING ) WRITE(NOUT,901) (P(I),I=1,N) 901 FORMAT(2X,10I8) CALL SYSOUT(N,NZRED,NZBLK,IA,JA,A,RHS,NOUT,ISYM) RETURN END SUBROUTINE TSTPRB (IA,JA,A,RHS,P,IP,IROW,ICOL) TSTP0010 C C TEST RED-BLACK INDEXING FOR SYSTEMS C INTEGER IA(1),JA(1),P(1),IP(1),IROW(1),ICOL(1) REAL A(1),RHS(1) C C COMMON /TBK31/ SRELPR, ZETA COMMON /TBK32/ IDEBUG, IERAN, ILEVEL, IORD, IPCT, IPLT, ISEED, A ISYM, ITMAX, LARGE, LEVEL, MAXNZ, MAXN, NOUT, B NBLACK, NB, NRBN, NRED, NW, NZBLK, NZRED, N C ITIM1 = ITICK(NDUMMY) C CALL PRBNDX ( N, NB, IA, JA, P, IP, ILEVEL, NOUT, IER ) C ITIM2 = ITOCK(NDUMMY) TIME = AMAX0(0,ITIM2-ITIM1)*1.E-3 C C PRINT RESULTS C NR = N - NB WRITE(NOUT,6010) NR,IER,TIME 6010 FORMAT(//5X,33HCOMPUTED NUMBER OF RED POINTS =, I5 C /5X,33HIER =, I5 D /5X,33HELAPSED TIME FOR INDEXING =, F5.3 / ) C C VERIFY RED-BLACK ORDERING C CALL PERMAT (N,IA,JA,A,P,ICOL,ISYM,ILEVEL,NOUT,IER) CALL PERVEC (N,RHS,P) IF(IER .NE. 0) STOP C IF(IPLT .EQ. 0) GO TO 899 WRITE(NOUT,6017) 6017 FORMAT(1H1/2X,45HPATTERN OF NONZEROS WITH RED-BLACK ORDERING /) CALL PLTADJ ( N, IA, JA, ISYM, IROW, ICOL, NOUT ) 899 IF ( IDEBUG .EQ. 0 ) GO TO 70 WRITE(NOUT,900) 900 FORMAT(//2X,14HDEBUG PRINTING A ,2X,33HP ARRAY AFTER RED-BLACK INDEXING ) WRITE(NOUT,901) (P(I),I=1,N) 901 FORMAT(2X,10I8) CALL SYSOUT(N,NZRED,NZBLK,IA,JA,A,RHS,NOUT,ISYM) 70 CONTINUE RETURN END SUBROUTINE TSTITP ( IA, JA, A, RHS , U, IWKSP, WKSP ) TSTI0010 C C PROGRAM TO EXERCISE ITPACK 2C C INTEGER IA(1),JA(1),IWKSP(1),IPARM(12),ITER(7),IWORK(7) REAL A(1),RHS(1),WKSP(1),RPARM(12),DIGIT1(7),DIGIT2(7),DIGIT3(7), A TIM1(7),TIM2(7),U(1) C COMMON /TBK31/ SRELPR, ZETA COMMON /TBK32/ IDEBUG, IERAN, ILEVEL, IORD, IPCT, IPLT, ISEED, A ISYM, ITMAX, LARGE, LEVEL, MAXNZ, MAXN, NOUT, B NBLACK, NB, NRBN, NRED, NW, NZBLK, NZRED, N C C TEST JCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL JCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(1)=RPARM(9) TIM2(1) = RPARM(10) DIGIT1(1) = RPARM(11) DIGIT2(1) = RPARM(12) CALL CHKNRM(U,WKSP,DIGIT3(1)) ITER(1)=IPARM(1) IWORK(1)=IPARM(8) C C TEST JSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL JSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(2)=RPARM(9) TIM2(2) = RPARM(10) DIGIT1(2) = RPARM(11) CALL CHKNRM(U,WKSP,DIGIT3(2)) DIGIT2(2) = RPARM(12) ITER(2)=IPARM(1) IWORK(2)=IPARM(8) C C TEST SOR C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SOR (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(3)=RPARM(9) TIM2(3) = RPARM(10) DIGIT1(3) = RPARM(11) CALL CHKNRM(U,WKSP,DIGIT3(3)) DIGIT2(3) = RPARM(12) ITER(3)=IPARM(1) IWORK(3)=IPARM(8) C C TEST SSORCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA RPARM(7)=.26E0 CALL VFILL (N,U,0.E0) CALL SSORCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(4)=RPARM(9) TIM2(4) = RPARM(10) DIGIT1(4) = RPARM(11) DIGIT2(4) = RPARM(12) CALL CHKNRM(U,WKSP,DIGIT3(4)) ITER(4)=IPARM(1) IWORK(4)=IPARM(8) C C TEST SSORSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL SSORSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(5)=RPARM(9) TIM2(5) = RPARM(10) DIGIT1(5) = RPARM(11) DIGIT2(5) = RPARM(12) CALL CHKNRM(U,WKSP,DIGIT3(5)) ITER(5)=IPARM(1) IWORK(5)=IPARM(8) C C TEST RSCG C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IF(IORD .EQ. 2) IPARM(9) = NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL RSCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(6)=RPARM(9) TIM2(6) = RPARM(10) DIGIT1(6) = RPARM(11) DIGIT2(6) = RPARM(12) CALL CHKNRM(U,WKSP,DIGIT3(6)) ITER(6)=IPARM(1) IWORK(6)=IPARM(8) C C TEST RSSI C CALL DFAULT (IPARM,RPARM) IPARM(1)=ITMAX IPARM(2)=LEVEL IPARM(5)=ISYM IF(IORD .EQ. 2) IPARM(9) = NB IPARM(12)=IERAN RPARM(1)=ZETA CALL VFILL (N,U,0.E0) CALL RSSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) TIM1(7)=RPARM(9) TIM2(7) = RPARM(10) DIGIT1(7) = RPARM(11) DIGIT2(7) = RPARM(12) CALL CHKNRM(U,WKSP,DIGIT3(7)) ITER(7)=IPARM(1) IWORK(7)=IPARM(8) C C TIMING ANALYSIS C NP1 = N+1 CALL TIME2 (N,IA,JA,A,WKSP,WKSP(NP1),ITER,TIM1,TIM2, A DIGIT1,DIGIT2,DIGIT3,IWORK,NOUT) C RETURN END SUBROUTINE TIME2 (N,IA,JA,A,V,W,ITER,TIM1,TIM2,DIGIT1,DIGIT2, TIME0010 A DIGIT3,IWORK,NOUT) INTEGER ITER(7),IA(1),JA(1),IWORK(7) REAL V(N),W(N),REL(7),A(1),DIGIT1(7),DIGIT2(7),DIGIT3(7), A TIM1(7),TIM2(7) DATA MAXLP/50/ C CALL VFILL (N,V,1.E0) ITIM1 = ITICK(NDUMMY) DO 10 I=1,MAXLP CALL PMULT (N,IA,JA,A,V,W) 10 CONTINUE ITIM2 = ITOCK(NDUMMY) TIMMAT = AMAX0(0,ITIM2 - ITIM1)*1.0E-3/FLOAT(MAXLP) C WRITE (NOUT,30) DO 20 I=1,7 REL(I) = 0.E0 TEMP = FLOAT(ITER(I)) IF ((ITIM2 .EQ. ITIM1) .OR. (ITER(I) .EQ. 0)) GO TO 20 REL(I) = TIM1(I)/(TEMP*TIMMAT) 20 CONTINUE C WRITE (NOUT,40) (TIM1(I),TIM2(I),ITER(I),REL(I),DIGIT1(I), A DIGIT2(I),DIGIT3(I),IWORK(I),I=1,7) C RETURN C 30 FORMAT(1H0,3(/),15X,15HTIMING ANALYSIS/15X,15(1H-)// A 35X,9HITERATION,3X,5HTOTAL,9X,6HNO. OF,4X,9HAVG ITER/, B 2X,6HDIGITS,4X,6HDIGITS,5X,6HDIGITS,5X,4HWKSP/15X, C 6HMETHOD,14X,10HTIME (SEC),2X,10HTIME (SEC),1X, D 10HITERATIONS,1X,12HMTX-VCTR MLT,1X,7HSTP TST, E 3X,7HRES/RHS,4X,4HTRUE,7X,4HUSED/15X,103(1H-)) 40 FORMAT(15X,17HJACOBI CG ,2F10.3,I14,F10.1,1X,3F10.1,I10/ 2 15X,17HJACOBI SI ,2F10.3,I14,F10.1,1X,3F10.1,I10/ 3 15X,17HSOR ,2F10.3,I14,F10.1,1X,3F10.1,I10/ 4 15X,17HSYMMETRIC SOR CG ,2F10.3,I14,F10.1,1X,3F10.1,I10/ 5 15X,17HSYMMETRIC SOR SI ,2F10.3,I14,F10.1,1X,3F10.1,I10/ 6 15X,17HREDUCED SYSTEM CG,2F10.3,I14,F10.1,1X,3F10.1,I10/ 7 15X,17HREDUCED SYSTEM SI,2F10.3,I14,F10.1,1X,3F10.1,I10/) C C END SUBROUTINE CHKNRM(U,WKSP,DIGIT) CHKN0010 C C COMPUTE TRUE RATIO C REAL U(1),WKSP(1) C COMMON /TBK31/ SRELPR, ZETA COMMON /TBK32/ IDEBUG, IERAN, ILEVEL, IORD, IPCT, IPLT, ISEED, A ISYM, ITMAX, LARGE, LEVEL, MAXNZ, MAXN, NOUT, B NBLACK, NB, NRBN, NRED, NW, NZBLK, NZRED, N C DO 10 I=1,N 10 WKSP(I) = U(I) - 1.E0 C DIGIT = -ALOG10(SRELPR) WKNRM = SDOT(N,WKSP,1,WKSP,1) IF(WKNRM .EQ. 0.E0) GO TO 20 DIGIT = -( ALOG10(WKNRM) - ALOG10(FLOAT(N)) )/2.0E0 C 20 IF(ILEVEL .EQ. 1) WRITE(NOUT,30) DIGIT 30 FORMAT(/13X,29HNO. OF DIGITS IN TRUE RATIO =,F5.1) C RETURN END INTEGER FUNCTION IRAND ( I, J, ISEED) IRAN0010 C C***************************************************************** C C THIS SUBPROGRAM GENERATES UNIFORMLY DISTRIBUTED RANDOM C INTEGERS BETWEEN I AND J (INCLUSIVE) C C****************************************************************** C INTEGER I, J, ISEED C C==================================================================== C IRAND = IFIX(FLOAT(J-I+1)*RANDOM(ISEED)) + I C RETURN END FUNCTION RANDOM(ISEED) RAND0010 C C RANDOM NUMBER GENERATOR - UNIFORMLY DISTRIBUTED IN (0,1) C ISEED IN (1,2147483647) C C FOLLOWING CODE USED BECAUSE OF POSSIBLE USE WITH C SHORT WORD LENGTH COMPUTERS C DOUBLE PRECISION DL DL = DMOD(16807.0D0*DBLE(FLOAT(ISEED)),2147483647.0D0) ISEED = IDINT(DL) RANDOM = SNGL(DL*4.6566128752458D-10) C C ON LONG WORD LENGTH COMPUTERS THE FOLLOWING CODE C MAY BE USED OR LOCAL RANDOM NUMBER GENERATOR C C ISEED = MOD(16807*ISEED,2147483647) C RANDOM = FLOAT(ISEED)*4.6566128752458E-10 C RETURN END SUBROUTINE PLTADJ ( N, IA, JA, ISYM, IROW, ICOL, NOUT ) PLTA0010 C C******************************************************************** C C THIS SUBROUTINE PLOTS THE ADJACENCY STRUCTURE OF A SPARE C MATRIX STORED IN SYMMETRIC/NONSYMMETRIC FORMAT C C WRITTEN BY ROGER G GRIMES AUGUST 1980 C C********************************************************************* C INTEGER N, IA(1), JA(1), ICOL(1), IROW(N) C INTEGER BLANK, STAR, I, M, IM1, KADD, IBGN, IEND, J, JJ C DATA BLANK / 1H /, STAR / 1H* / C C==================================================================== C C ... SET WORKSPACE ARRAYS TO ALL BLANKS. IROW WILL BE USED TO INDICATE C THE ADJACENCY STRUCTURE FOR THE CURRENT ROW. ICOL WILL STORE THE C ADJACENCY STRUCTURE FOR THE LOWER TRIANGLE FOR COLUMNS 1 THRU C THE CURRENT COLUMN ( SAME AS CURRENT ROW ). C DO 10 I = 1, N IROW(I) = BLANK 10 CONTINUE IF (ISYM .NE. 0) GO TO 25 M = N * ( N + 1 ) / 2 DO 20 I = 1, M ICOL(I) = BLANK 20 CONTINUE C C ... LOOP OVER EACH ROW ( AND COLUMN ) C 25 KADD = 0 DO 80 I = 1, N IM1 = I - 1 KADD = KADD + IM1 IBGN = IA(I) IEND = IA(I+1) - 1 IF ( IBGN .GT. IEND ) GO TO 40 DO 30 J = IBGN, IEND JJ = JA(J) IROW(JJ) = STAR IF (ISYM .NE. 0) GO TO 30 K = ( JJ-1 ) * JJ / 2 + I ICOL(K) = STAR 30 CONTINUE IF ( I .EQ. 1 ) GO TO 55 IF (ISYM .NE. 0) GO TO 55 40 DO 50 J = 1, IM1 ITEMP = KADD + J IROW(J) = ICOL ( ITEMP ) 50 CONTINUE 55 WRITE(NOUT,60) I, (IROW(K),K=1,N) 60 FORMAT ( 2X,I5,3X,120A1) DO 70 J = 1, N IROW(J) = BLANK 70 CONTINUE 80 CONTINUE C C ... RETURN C RETURN END SUBROUTINE SYSOUT(N,NZRED,NZBLK,IA,JA,A,RHS,NOUT,ISYM) SYSO0010 C C PRINT SYSTEM OUT IN 2X2 FORMAT IF N .LE. 10 C INTEGER IA(1),JA(1) REAL A(1),RHS(1),TMP(10,10) C WRITE(NOUT,51) 51 FORMAT(16H0 SYSTEM (A,B) ) C IF (N .GT. 10) GO TO 50 C DO 5 I=1,N DO 5 J=1,N 5 TMP(I,J) = 0.E0 C DO 10 I=1,N IBGN = IA(I) IEND = IA(I+1) - 1 IF(IBGN .GT. IEND) GO TO 10 DO 20 J=IBGN,IEND JAJ = JA(J) TMP(I,JAJ) = A(J) IF(ISYM .EQ. 0) TMP(JAJ,I) = A(J) 20 CONTINUE 10 CONTINUE C DO 15 I=1,N WRITE(NOUT,992) (TMP(I,J),J=1,N),RHS(I) 15 CONTINUE RETURN C 50 CONTINUE WRITE(NOUT,880) 880 FORMAT(//2X,8HIA ARRAY ) IEND = N + 1 WRITE(NOUT,991) (IA(I),I=1,IEND) 991 FORMAT(2X,10I8) IEND = IA(IEND) - 1 WRITE(NOUT,881) 881 FORMAT(//2X,8HJA ARRAY ) WRITE(NOUT,991) ( JA(I),I=1,IEND ) NZEND = NZRED + N IF(ISYM .NE. 0) NZEND = NZEND + NZBLK WRITE(NOUT,882) 882 FORMAT(//2X,8HA ARRAY ) WRITE(NOUT,992) ( A(I),I=1,NZEND) WRITE(NOUT,883) 883 FORMAT(//2X,10HRHS ARRAY ) WRITE(NOUT,992) ( RHS(I),I=1,N) 992 FORMAT(/2X,11(1X,G11.4)) C RETURN END SUBROUTINE TEST4(EPSI) TEST0010 C C ... TEST4 EXERCISES ITPACK 2C WITH VARIOUS SWITCHES SET C ON THE LINEAR SYSTEM CORRESPONDING TO THE FINITE C DIFFERENCE SOLUTION TO THE PDE C C U + U + BU = F C XX YY X C C SUBJECT TO U(.,0) = U(.,1) = U(0,.) = U(1,.) = 0 C C WHERE F = 2X(X-1) + Y(Y-1)(2-B(1-2X)). THE TRUE SOLUTION C IS U = XY(1-X)(1-Y). THE MESH SIZE IS 1/4. C INTEGER IA(10),JA(33),IPARM(12),IWKSP(27) REAL A(33),RHS(9),U(9),RPARM(12),WKSP(460) C F(X,Y,BTA) = 2.*X*(X-1.)+Y*(Y-1.)*(2.-BTA*(1.-2.*X)) C NW=460 N=9 LEVEL=0 IDGTS=1 NOUT=6 WRITE(NOUT,2) 2 FORMAT(1H1 //15X,32HITPACK 2C TEST PROGRAM -- TEST4 ) C C ************* START LOOP TO DO BOTH CASES ****************** C DO 80 K=2,11,9 BETA=FLOAT(K-2) H=1./4. B=1./4. C=1./2. D=3./4. RHS(1)=-H*H*F(B,B,BETA) RHS(2)=-H*H*F(C,B,BETA) RHS(3)=-H*H*F(D,B,BETA) RHS(4)=-H*H*F(B,C,BETA) RHS(5)=-H*H*F(C,C,BETA) RHS(6)=-H*H*F(D,C,BETA) RHS(7)=-H*H*F(B,D,BETA) RHS(8)=-H*H*F(C,D,BETA) RHS(9)=-H*H*F(D,D,BETA) IBGN=2 IF(K .EQ. 2) IBGN=1 DO 80 I=IBGN,2 WRITE(NOUT,5) WRITE(NOUT,6) BETA 5 FORMAT(50H0 *********************************************** ) 6 FORMAT(5X,7H BETA =,F10.5) ISYM=I-1 IF(ISYM .EQ. 0) CALL SSEXP(IA,JA,A,NOUT) IF(ISYM .NE. 0) CALL NSEXP(IA,JA,A,BETA,H,NOUT) C C C TEST JCG C DO 10 KK=1,2 IADAPT=KK-1 CALL DFAULT (IPARM,RPARM) IPARM(1)=12 IPARM(2)=LEVEL IF(IADAPT .EQ. 0) IPARM(2)=5 IPARM(5)=ISYM IPARM(6)=IADAPT IPARM(12)=IDGTS RPARM(1)=1.E-20 RPARM(2)=.75E0 RPARM(3)=-.65E0 CALL VFILL (N,U,5.E-2) CALL JCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) 10 CONTINUE C C TEST JSI C DO 20 ICASE=1,2 DO 20 KK=1,2 IADAPT=KK-1 CALL DFAULT (IPARM,RPARM) IPARM(1)=27 IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(6)=IADAPT IPARM(7)=ICASE IPARM(12)=IDGTS RPARM(1)=1.E-1 RPARM(2)=.75E0 RPARM(3)=-.65E0 RPARM(4)=1.E0 CALL VFILL (N,U,1.E0) CALL JSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) 20 CONTINUE C C TEST SOR C DO 30 KK=1,2 IADAPT=KK-1 CALL DFAULT (IPARM,RPARM) IPARM(1)=10 IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(6)=IADAPT IPARM(7)=2 IPARM(12)=IDGTS RPARM(1)=1.E-3 RPARM(2)=.71E0 RPARM(3)=-.89E0 RPARM(5)=1.2 CALL VFILL (N,U,0.E0) CALL SOR (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) 30 CONTINUE C C TEST SSORCG C DO 40 ICASE=1,2 DO 40 KK=1,4 IADAPT=KK-1 CALL DFAULT (IPARM,RPARM) IPARM(1)=4 IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(6)=IADAPT IPARM(7)=ICASE IPARM(12)=IDGTS RPARM(1)=1.0E-6 RPARM(2)=.8E0 RPARM(3)=-.25E0 RPARM(5)=1.2E0 RPARM(6)=.9E0 RPARM(7)=.26E0 CALL VFILL (N,U,0.E0) CALL SSORCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) 40 CONTINUE C C TEST SSORSI C DO 50 ICASE=1,2 DO 50 KK=1,4 IADAPT=KK-1 CALL DFAULT (IPARM,RPARM) IPARM(1)=8 IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(6)=IADAPT IPARM(7)=ICASE IPARM(12)=IDGTS RPARM(2)=.22E0 RPARM(5)=1.25E0 RPARM(6)=.25E0 RPARM(7)=.24E0 CALL VFILL (N,U,0.E0) CALL SSORSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) 50 CONTINUE C C TEST RSCG C DO 60 KK=1,2 IADAPT=KK-1 CALL DFAULT (IPARM,RPARM) IPARM(1)=4 IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(6)=IADAPT IPARM(12)=IDGTS IF(IADAPT .EQ. 0) IPARM(12) = 4 RPARM(1)=1.0E-20 RPARM(2)=.85E0 RPARM(3)=-.5E0 RPARM(4)=.5E0 CALL VFILL (N,U,5.E-2) CALL RSCG (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) 60 CONTINUE C C TEST RSSI C DO 70 KK=1,2 IADAPT=KK-1 CALL DFAULT (IPARM,RPARM) IPARM(1)=20 IPARM(2)=LEVEL IPARM(5)=ISYM IPARM(6)=IADAPT IPARM(12)=IDGTS RPARM(2)=.9E0 RPARM(3)=-.75E0 CALL VFILL (N,U,0.E0) CALL RSSI (N,IA,JA,A,RHS,U,IWKSP,NW,WKSP,IPARM,RPARM,IER) 70 CONTINUE C 80 CONTINUE C RETURN END SUBROUTINE SSEXP(IA,JA,A,NOUT) SSEX0010 INTEGER IA(10),JA(33) REAL A(33) WRITE(NOUT,10) 10 FORMAT(24H0 SYMMETRIC STORAGE USED ) A(21)=4.0 A(19)=A(21) A(17)=A(19) A(15)=A(17) A(12)=A(15) A(9)=A(12) A(7)=A(9) A(4)=A(7) A(1)=A(4) A(20)=-1.0 A(18)=A(20) A(16)=A(18) A(14)=A(16) A(13)=A(14) A(11)=A(13) A(10)=A(11) A(8)=A(10) A(6)=A(8) A(5)=A(6) A(3)=A(5) A(2)=A(3) JA(1)=1 JA(2)=2 JA(3)=4 JA(4)=2 JA(5)=3 JA(6)=5 JA(7)=3 JA(8)=6 JA(9)=4 JA(10)=5 JA(11)=7 JA(12)=5 JA(13)=6 JA(14)=8 JA(15)=6 JA(16)=9 JA(17)=7 JA(18)=8 JA(19)=8 JA(20)=9 JA(21)=9 IA(1)=1 IA(2)=4 IA(3)=7 IA(4)=9 IA(5)=12 IA(6)=15 IA(7)=17 IA(8)=19 IA(9)=21 IA(10)=22 RETURN C END SUBROUTINE NSEXP(IA,JA,A,BETA,H,NOUT) NSEX0010 INTEGER IA(10),JA(33) REAL A(33) WRITE(NOUT,10) 10 FORMAT(27H0 NONSYMMETRIC STORAGE USED ) JA(1)=1 JA(2)=2 JA(3)=4 JA(4)=1 JA(5)=2 JA(6)=3 JA(7)=5 JA(8)=2 JA(9)=3 JA(10)=6 JA(11)=1 JA(12)=4 JA(13)=5 JA(14)=7 JA(15)=2 JA(16)=4 JA(17)=5 JA(18)=6 JA(19)=8 JA(20)=3 JA(21)=5 JA(22)=6 JA(23)=9 JA(24)=4 JA(25)=7 JA(26)=8 JA(27)=5 JA(28)=7 JA(29)=8 JA(30)=9 JA(31)=6 JA(32)=8 JA(33)=9 IA(1)=1 IA(2)=4 IA(3)=8 IA(4)=11 IA(5)=15 IA(6)=20 IA(7)=24 IA(8)=27 IA(9)=31 IA(10)=34 A(33)=4.0 A(29)=A(33) A(25)=A(29) A(22)=A(25) A(17)=A(22) A(12)=A(17) A(9)=A(12) A(5)=A(9) A(1)=A(5) A(31)=-1.0 A(27)=A(31) A(24)=A(27) A(23)=A(24) A(20)=A(23) A(19)=A(20) A(15)=A(19) A(14)=A(15) A(11)=A(14) A(10)=A(11) A(7)=A(10) A(3)=A(7) A(30)=-(1.+0.5*H*BETA) A(26)=A(30) A(18)=A(26) A(13)=A(18) A(6)=A(13) A(2)=A(6) A(32)=-(1.-0.5*H*BETA) A(28)=A(32) A(21)=A(28) A(16)=A(21) A(8)=A(16) A(4)=A(8) RETURN C END