*********************************************************************** * The FORTRAN source code for the generic version of LANZ. * * * * The first few routines in this file comprise the test program. * * They are separated from the rest of the file by a comment * * section similar to this one. The rest of the file contains * * the LANZ source code. * * * * For illustration purposes, the installation steps needed to * * create an executable verion of LANZ, including the test * * programs, on the IBM 3090 running AIX are now given: * * First the two files are given suffixes that reflect the type * * of source code contained in them: * * mv lanz.file3 lanz.file3.f * * mv lanz.file4 lanz.file4.c * * * * Next the C compiler is invoked to create lanz.file4.o: * * cc -O -c lanz.file4.c * * * * Lastly the FORTRAN compiler is called to create the * * executable, lanz.ibm: * * fvs -xa -f'opt(3) vec' -o lanz.ibm lanz.file3.f lanz.file4.o * * * *********************************************************************** C$FORTRAN BISEC1 *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: BISECT.MSC * * AUTHOR: MARK JONES * * PURPOSE: USED IN THE TRIDIAGONAL EIGENSOLVER TO PROTECT THE * * NEWTON ROOTFINDER FROM STRAYING OUT OF BOUNDS * *********************************************************************** SUBROUTINE BISEC1(J,ALF,BET2,LEFT,RIGHT,EPS,INDEX,DEBUG) * THE ORDER OF T(J) INTEGER J * ALF IS THE DIAGONAL OF T(J) DOUBLE PRECISION ALF(J) * BET2 IS THE SQUARE OF THE OFF-DIAGONAL OF T(J) DOUBLE PRECISION BET2(J) * LEFT (RIGHT) BOUND ON INTERVAL DOUBLE PRECISION LEFT, RIGHT * EPSILON IS THE MACHINE PRECISION DOUBLE PRECISION EPS * THE NUMBER OF THE EIGENVALUE THAT WE ARE SEEKING INTEGER INDEX * THE LEVEL OF DEBUGGING OUTPUT INTEGER DEBUG * THE FOLLOWING ARE INTERNAL VARIABLES * THE SIZE OF THE BOUND DOUBLE PRECISION DIST, ODIST * THE DIRECTION CURRENTLY MOVING INTEGER DIRECT * HAVE WE SWITCHED DIRECTION? LOGICAL BTRACK * NUMBERS OF EIGENVALUES AT CERTAIN PROBES INTEGER NUMRIG, NUMLEF, NUMMID * THE MID POINT OF THE RANGE DOUBLE PRECISION MID * AN INTEGER FUNCTION INTEGER NUMLES EXTERNAL NUMLES ODIST = RIGHT - LEFT IF (ODIST.LE.0.0D0) THEN ODIST = ABS(RIGHT * (4.0D0*EPS)) IF (ODIST.EQ.0.0D0) THEN ODIST = EPS ENDIF ENDIF DIST = ODIST DIRECT = 0 BTRACK = .FALSE. * ADJUST THE RIGHT SIDE OF THE BOUND 10 CONTINUE NUMRIG = NUMLES(ALF,BET2,RIGHT,J,1,EPS) IF (NUMRIG.LT.INDEX) THEN IF (DEBUG.GT.0) THEN PRINT *,'WARNING: BISECT DETECTS NUMERICAL PROBLEM' PRINT *,'FIXED:ADJUSTED RIGHT SIDE TO RIGHT' PRINT *,DIRECT,' ',DIST,' ',ODIST,' ',RIGHT,' ',J ENDIF RIGHT = RIGHT + DIST IF ((DIRECT.EQ.2).OR.(BTRACK)) THEN DIST = DIST/2 IF (DIST.LE.0.0D0) THEN DIST = ABS(RIGHT * (2.0D0*EPS)) ENDIF BTRACK = .TRUE. ELSE DIST = DIST*2 ENDIF DIRECT = 1 GOTO 10 ELSE IF (NUMRIG.GT.INDEX) THEN IF (DEBUG.GT.0) THEN PRINT *,'WARNING: BISECT DETECTS NUMERICAL PROBLEM' PRINT *,'FIXED:ADJUSTED RIGHT SIDE TO LEFT' ENDIF RIGHT = RIGHT - DIST IF ((DIRECT.EQ.1).OR.(BTRACK)) THEN DIST = DIST/2 IF (DIST.LE.0.0D0) THEN DIST = ABS(RIGHT * (2.0D0*EPS)) ENDIF BTRACK = .TRUE. ELSE DIST = DIST*2 ENDIF DIRECT = 2 GOTO 10 ENDIF * ADJUST THE LEFT SIDE OF THE BOUND DIST = ODIST DIRECT = 0 BTRACK = .FALSE. 20 CONTINUE NUMLEF = NUMLES(ALF,BET2,LEFT,J,1,EPS) IF (NUMLEF.LT.INDEX-1) THEN IF (DEBUG.GT.0) THEN PRINT *,'WARNING: BISECT DETECTS NUMERICAL PROBLEM' PRINT *,'FIXED:ADJUSTED LEFT SIDE TO RIGHT' ENDIF LEFT = LEFT + DIST IF ((DIRECT.EQ.2).OR.(BTRACK)) THEN DIST = DIST/2 IF (DIST.LE.0.0D0) THEN DIST = ABS(LEFT * (2.0D0*EPS)) ENDIF BTRACK = .TRUE. ELSE DIST = DIST*2 ENDIF DIRECT = 1 GOTO 20 ELSE IF (NUMLEF.GT.INDEX-1) THEN IF (DEBUG.GT.0) THEN PRINT *,'WARNING: BISECT DETECTS NUMERICAL PROBLEM' PRINT *,'FIXED:ADJUSTED LEFT SIDE TO LEFT' ENDIF LEFT = LEFT - DIST IF ((DIRECT.EQ.1).OR.(BTRACK)) THEN DIST = DIST/2 IF (DIST.LE.0.0D0) THEN DIST = ABS(LEFT * (2.0D0*EPS)) ENDIF BTRACK = .TRUE. ELSE DIST = DIST*2 ENDIF DIRECT = 2 GOTO 20 ENDIF MID = (RIGHT + LEFT)/2.0D0 NUMMID = NUMLES(ALF,BET2,MID,J,1,EPS) IF (NUMMID.EQ.NUMRIG) THEN RIGHT = MID ELSE LEFT = MID ENDIF RETURN END C$FORTRAN BSTATE *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: BOUND.MSC * * AUTHOR: MARK JONES * * PURPOSE: USED IN MSHIFT() TO DETERMINE THE BOUNDARIES WHEN * * SEARCHING FOR EIGENPAIRS IN A PRE-DETERMINED RANGE * *********************************************************************** SUBROUTINE BSTATE(STATE,ISLFT,ISRGT,LFTVAL,RGTVAL,RETVAL, C BLEFT,BRIGHT,RUN) * THE CURRENT STATE INTEGER STATE * DO WE HAVE LEFT AND RIGHT SHIFTS LOGICAL ISRGT, ISLFT * LEFT AND RIGHT SHIFTS DOUBLE PRECISION RGTVAL, LFTVAL * RETURN FROM LAST LANCZOS RUN INTEGER RETVAL * LEFT AND RIGHT BOUNDARIES DOUBLE PRECISION BLEFT,BRIGHT * THE LOOP VARIABLE FROM THE CALLING ROUTINE TO RESET INTEGER RUN IF (STATE.EQ.0) THEN RETURN ELSE IF (STATE.EQ.-1) THEN STATE = 1 ELSE IF (STATE.EQ.1) THEN IF (RETVAL.EQ.0) THEN STATE = 4 ISRGT = .TRUE. ISLFT = .TRUE. RGTVAL = BRIGHT LFTVAL = BLEFT RUN = 1 ELSE STATE = 2 ENDIF ELSE IF ((STATE.EQ.2).OR.(STATE.EQ.3)) THEN IF ((RGTVAL.GE.BRIGHT).OR.(RGTVAL.LE.BLEFT)) THEN ISRGT = .FALSE. ENDIF IF ((LFTVAL.GE.BRIGHT).OR.(LFTVAL.LE.BLEFT)) THEN ISLFT = .FALSE. ENDIF IF (.NOT.((ISRGT).OR.(ISLFT))) THEN STATE = 4 ISRGT = .TRUE. ISLFT = .TRUE. RGTVAL = BRIGHT LFTVAL = BLEFT ENDIF ELSE IF (STATE.EQ.4) THEN STATE = 5 ELSE IF (STATE.EQ.5) THEN STATE = 0 ENDIF RETURN END INTEGER FUNCTION GBOUND(INTIDX,SIGLST,INTLST,BLEFT,BRIGHT,JOB) * THE NUMBER OF INERTIA CHECKS INTEGER INTIDX * THE SIGMAS DOUBLE PRECISION SIGLST(*) * THE INERTIAS INTEGER INTLST(*) * THE LEFT AND RIGHT BOUNDS DOUBLE PRECISION BLEFT, BRIGHT * THE JOB TO DO INTEGER JOB * INTERNAL VARIABLES INTEGER NLEFT, NRIGHT, NMID DOUBLE PRECISION MID INTEGER I MID = (BRIGHT + BLEFT) / 2.0D0 DO 10 I = 1, INTIDX IF (SIGLST(I).EQ.BLEFT) THEN NLEFT = INTLST(I) ELSE IF (SIGLST(I).EQ.BRIGHT) THEN NRIGHT = INTLST(I) ELSE IF (SIGLST(I).EQ.MID) THEN NMID = INTLST(I) ENDIF 10 CONTINUE IF (JOB.EQ.0) THEN GBOUND = NRIGHT - NLEFT ELSE IF (JOB.EQ.4) THEN GBOUND = NRIGHT - NMID ELSE GBOUND = NMID - NLEFT ENDIF RETURN END C$FORTRAN BSORT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: BSORT.MSC * * AUTHOR: MARK JONES * * PURPOSE: BUBBLESORT ROUTINES USED TO SORT SMALL VECTORS * *********************************************************************** * SORTS 1 DOUBLE PRECISION VECTOR SUBROUTINE BSORT(N,INVEC) * THE LENGTH OF THE VECTOR INTEGER N * THE DOUBLE PRECISION VECTOR TO BE SORTED DOUBLE PRECISION INVEC(*) * THE REST ARE INTERNAL VARIABLES * COUNT VARIABLES INTEGER I,J * A TEMPORARY VARIABLE DOUBLE PRECISION TEMP DO 10 I = 1, N-1 DO 20 J = I+1, N IF (INVEC(I).GT.INVEC(J)) THEN TEMP = INVEC(I) INVEC(I) = INVEC(J) INVEC(J) = TEMP ENDIF 20 CONTINUE 10 CONTINUE RETURN END * SORTS A DOUBLE PRECISION VECTOR WITH A DATA INTEGER VECTOR SUBROUTINE BSORT2(N,KEYVEC,DVEC) * THE LENGTH OF THE VECTOR INTEGER N * THE DOUBLE PRECISION VECTOR TO BE SORTED DOUBLE PRECISION KEYVEC(*) * THE INTEGER VECTOR ASSOCIATED WITH KEYVEC INTEGER DVEC(*) * THE REST ARE INTERNAL VARIABLES * COUNT VARIABLES INTEGER I,J * A TEMPORARY VARIABLE DOUBLE PRECISION TEMP * A TEMPORARY VARIABLE INTEGER ITEMP DO 10 I = 1, N-1 DO 20 J = I+1, N IF (KEYVEC(I).GT.KEYVEC(J)) THEN TEMP = KEYVEC(I) KEYVEC(I) = KEYVEC(J) KEYVEC(J) = TEMP ITEMP = DVEC(I) DVEC(I) = DVEC(J) DVEC(J) = ITEMP ENDIF 20 CONTINUE 10 CONTINUE RETURN END * SORTS A DOUBLE PRECISION VECTOR WITH TWO DATA VECTORS SUBROUTINE BSORT3(N,KEYVEC,DVEC1,DVEC2) * THE LENGTH OF THE VECTOR INTEGER N * THE DOUBLE PRECISION VECTOR TO BE SORTED DOUBLE PRECISION KEYVEC(*) * THE INTEGER VECTOR ASSOCIATED WITH KEYVEC INTEGER DVEC1(*) * THE DOUBLE PRECISION VECTOR ASSOCIATED WITH KEYVEC DOUBLE PRECISION DVEC2(*) * THE REST ARE INTERNAL VARIABLES * COUNT VARIABLES INTEGER I,J * A TEMPORARY VARIABLE DOUBLE PRECISION TEMP * A TEMPORARY VARIABLE INTEGER ITEMP DO 10 I = 1, N-1 DO 20 J = I+1, N IF (KEYVEC(I).GT.KEYVEC(J)) THEN TEMP = KEYVEC(I) KEYVEC(I) = KEYVEC(J) KEYVEC(J) = TEMP ITEMP = DVEC1(I) DVEC1(I) = DVEC1(J) DVEC1(J) = ITEMP TEMP = DVEC2(I) DVEC2(I) = DVEC2(J) DVEC2(J) = TEMP ENDIF 20 CONTINUE 10 CONTINUE RETURN END * SORTS AN INTEGER VECTOR WITH A DATA DOUBLE PRECISION VECTOR SUBROUTINE BSORTT(N,KEYVEC,DVEC) * THE LENGTH OF THE VECTOR INTEGER N * THE DOUBLE PRECISION VECTOR TO BE SORTED INTEGER KEYVEC(*) * THE INTEGER VECTOR ASSOCIATED WITH KEYVEC DOUBLE PRECISION DVEC(*) * THE REST ARE INTERNAL VARIABLES * COUNT VARIABLES INTEGER I,J * A TEMPORARY VARIABLE INTEGER TEMP * A TEMPORARY VARIABLE DOUBLE PRECISION ITEMP DO 10 I = 1, N-1 DO 20 J = I+1, N IF (KEYVEC(I).GT.KEYVEC(J)) THEN TEMP = KEYVEC(I) KEYVEC(I) = KEYVEC(J) KEYVEC(J) = TEMP ITEMP = DVEC(I) DVEC(I) = DVEC(J) DVEC(J) = ITEMP ENDIF 20 CONTINUE 10 CONTINUE RETURN END C$FORTRAN BUNCH *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: BUNCH.MSC * * AUTHOR: MARK JONES * * PURPOSE: BANDED BUNCH-KAUFMAN FACTORIZATION AND FORWARD/BACK * * SOLUTION AS DESCRIBED BY JONES AND PATRICK * * CONTAINS BOTH A VECTOR AND A NON-VECTOR VERSION * *********************************************************************** * THE NON-VECTOR VERSION SUBROUTINE BUNCH(N,K,KRP,KCP,M,MRP,MCP, C A,ROWPTR,RWSTRT,B,X,SIGMA,INFLAG,MXSIZE, C DIAG,SUBDAG,V,V2,V3,V4,V5,V6,VL,VL2,VL3,VL4,VL5,VL6, C P,IUPTO,INERT,DEBUG,CMOFF,CMRP,CMCP, C CKOFF,CKRP,CKCP,UNROLL) * N IS THE ORDER OF THE MATRIX INTEGER N * K IS A SPARSE MATRIX DOUBLE PRECISION K(*) * KRP CONTAINS THE ROW POINTERS FOR K INTEGER KRP(*) * KCP CONTAINS THE COLUMN NUMBERS FOR K INTEGER KCP(*) * M IS A SPARSE MATRIX DOUBLE PRECISION M(*) * MRP CONTAINS THE ROW POINTERS FOR M INTEGER MRP(*) * MCP CONTAINS THE COLUMN NUMBERS FOR M INTEGER MCP(*) * A IS THE FACTORED VERSION OF (K-SIGMA*M) DOUBLE PRECISION A(*) * ROWPTR POINTS TO THE ROWS OF A INTEGER ROWPTR(*) * RWSTRT CONTAINS THE COLUMN NUMBER OF (K-SIGMA*M) WHERE * EACH ROW STARTS INTEGER RWSTRT(*) * B IS THE RIGHT-HAND SIDE DOUBLE PRECISION B(*) * X IS THE SOLUTION TO AX=B DOUBLE PRECISION X(*) * SIGMA IS THE SHIFT BEING USED DOUBLE PRECISION SIGMA * INDICATES WHAT COMBINATION OF FACT, FORWARD AND BACK SOLVE TO DO INTEGER INFLAG * THE MAXIMUM AMOUNT OF SPACE ALLOCATED FOR A INTEGER MXSIZE * WORK VECTORS FOR THE ALGORITHM * THE DIAGONAL OF THE D MATRIX DOUBLE PRECISION DIAG(*) * THE OFF-DIAGONAL OF THE D MATRIX DOUBLE PRECISION SUBDAG(*) * THE FOLLOWING VECTORS ARE USED WHEN UPDATING THE A MATRIX DOUBLE PRECISION V(*) DOUBLE PRECISION V2(*) DOUBLE PRECISION V3(*) DOUBLE PRECISION V4(*) DOUBLE PRECISION V5(*) DOUBLE PRECISION V6(*) DOUBLE PRECISION VL(*) DOUBLE PRECISION VL2(*) DOUBLE PRECISION VL3(*) DOUBLE PRECISION VL4(*) DOUBLE PRECISION VL5(*) DOUBLE PRECISION VL6(*) * A VECTOR TO KEEP TRACK OF PERMUTATIONS INTEGER P(*) * RECORDS HOW MANY COLUMNS CONTAIN NON-ZEROES BELOW A ROW INTEGER IUPTO(*) * THE INERT INTEGER INERT * THE DEBUGGING LEVEL INTEGER DEBUG * THE FOLLOWING ARE THE K AND M MATRICES STORED BY COLUMNS DOUBLE PRECISION CMOFF(*), CKOFF(*) INTEGER CMRP(*), CKRP(*) INTEGER CMCP(*), CKCP(*) * THE LEVEL OF LOOP UNROLLING INTEGER UNROLL * SOME INTERNAL VARIABLES * COUNT VARIABLES INTEGER L, I, J, START, RSTART, NSTART, ISTART, MYNUM, IMULT INTEGER IT1, IT2, IT3, IT4, IT5, IT6, IT7, IT8, II, IOFF * THE MAXIMUM LEVEL OF COMBINING OF ROWS IN THE TRIANGULAR SOLVES INTEGER ICMAX * THE NUMBER OF ROWS TO WORK ON IN THE TRIANGULAR SOLVES INTEGER NUMROW * RECORDS THE LAST ROW READ FROM K AND M INTO A INTEGER UPTO * THE ROW AT STEP L CONTAINING THE LARGEST ELEMENT * JUST AS IN THE JONES-PATRICK PAPER INTEGER TR(1), R * THE FIRST EMPTY ELEMENT IN A INTEGER NEXT * USED TO STORE THE RESULTS OF MIN AND MAX CALLS INTEGER TMPMAX * TEMPORARY VARIABLES FOR LOOPS DOUBLE PRECISION T, T1, T2, T3, T4, T5, T6, T7, TX * TEMPORARY VARIABLES FOR LOOPS DOUBLE PRECISION AT, AT1, AT2, AT3, AT4, AT5 * SOME OF THE VALUES IN THE PIVOT BLOCK * A * B C * D E F * G H I J * K L M N O * P Q R S T U DOUBLE PRECISION PAVAL, PBVAL, PCVAL, PDVAL, PEVAL, PFVAL, C PGVAL, PHVAL, PIVAL, PJVAL, PKVAL, PLVAL, PMVAL, PNVAL, POVAL, C PPVAL, PQVAL, PRVAL, PSVAL, PTVAL, PUVAL * TEMPORARY HOLDING VALUES FOR THE PIVOT BLOCK DOUBLE PRECISION TBVAL, TDVAL, TEVAL, TGVAL, THVAL, TIVAL, C TKVAL, TLVAL, TMVAL, TNVAL, TPVAL, TQVAL, TRVAL, TSVAL, TTVAL * STABILITY TEST LEVELS FOR PIVOTS DOUBLE PRECISION SLVL1, SLVL2, SLVL3, SLVL4, SLVL5, SLVL6, SLVLM * THE ELEMENT GROWTH BOUNDS FOR PIVOTS DOUBLE PRECISION GRATE1, GRATE2, GRATE3, GRATE4, GRATE5, GRATE6 DOUBLE PRECISION TLAM2, TLAM3, TLAM4, TLAM5, TLAM6 * THE RATIO OF LAMBDA TO PAVAL DOUBLE PRECISION LRATIO * USED TO STORE THE INVERSE OF THE 2X2 PIVOT DOUBLE PRECISION A11, A21, A22 * THE DETERMINANT OF THE 2X2 PIVOT DOUBLE PRECISION DETERM * MU AND LAMBDA FROM THE JONES-PATRICK PAPER DOUBLE PRECISION MU, LAMBDA(6,1) * THE PIVOTING DECISION CRITERION FROM BUNCH-KAUFMAN DOUBLE PRECISION CRIT * HOW MANY STEPS TO SKIP INTEGER NSKIP * SOME COUNTING VARIABLES TO GATHER INFORMATION (WILL GO) * A LOCAL VARIABLE FOR LOOP UNROLLING INTEGER IADDR INTEGER ME, NPROCS * TEMPORARY LEVEL OF LOOP UNROLLING INTEGER TNROLL * COMMUNICATION VARIABLE * INTEGER FUNCTIONS INTEGER IGETMX, LOCAL2 EXTERNAL IGETMX, LOCAL2, L2TMON, L2TMOF, CPYVEC * LINE NUMBER CONVENTIONS * 0-99: TEMPORARY CODE * 100-102: MAIN LOOP AND END OF MAIN LOOP * 110-199: READING IN MATRIX ELEMENTS THE 1ST TIME * 200-299: PIVOT SIZE DETERMINATION * 300-399: SEARCH FOR MU * 400-449: 1X1 PIVOT * 450-549: CHANGE AND READ MATRIX FOR A B-K 2X2 PIVOT * 550-599: B-K 2X2 PIVOT * 600-649: 2X2 PIVOT STEP * 650-699: 3X3 PIVOT STEP * 700-749: 4X4 PIVOT STEP * 1000-1049: 5X5 PIVOT STEP * 1050-1099: 6X6 PIVOT STEP * 750-799: EMPTY PIVOT STEP * 800-899: FORWARD, BACK, AND DIAGONAL SOLVES * 8000-8999: MORE BACK SOLVE * 1500-1549: REGROUPING AFTER FACTORIZATION * 4000-4600: PARALLEL SYNC. * 5000-6000: FIND NEXT LAMBDA IN PARALLEL * FACTOR THE MATRIX IF IT HASN'T BEEN DONE BEFORE IF ((INFLAG.EQ.0).OR.(INFLAG.EQ.6)) THEN ME = 1 NPROCS = 1 UPTO = 0 * TIME THE FACTORIZATION INTERNALLY IF (DEBUG.EQ.-2) THEN CALL L2TMON() ENDIF NEXT = 1 CRIT = 0.525D0 NSKIP = 0 SLVL1 = 1.0D0 + (1.0D0/CRIT) SLVL2 = SLVL1*SLVL1 SLVL3 = SLVL1*SLVL2 SLVL4 = SLVL2*SLVL2 SLVL5 = SLVL1*SLVL4 SLVL6 = SLVL3*SLVL3 GOTO (1,2,3,4,5,6) UNROLL PRINT *,'ERROR: ONLY LEVELS 1-6 ARE ALLOWED IN LOOP UNROLLING' STOP 1 SLVLM = SLVL1 GOTO 7 2 SLVLM = SLVL2 GOTO 7 3 SLVLM = SLVL3 GOTO 7 4 SLVLM = SLVL4 GOTO 7 5 SLVLM = SLVL5 GOTO 7 6 SLVLM = SLVL6 GOTO 7 7 CONTINUE INERT = 0 DO 20 I = 1, UNROLL LAMBDA(I,ME) = 0.0 20 CONTINUE TNROLL = UNROLL * START THE BUNCH FACTORIZATION LOOP DO 100 L = 1, N * SKIP IF A 2X2 PIVOT WAS DONE LAST STEP IF (NSKIP.GT.0) THEN NSKIP = NSKIP-1 GOTO 102 ENDIF * DETERMINE WHAT ROWS NEED TO BE READ IN * GET ALL THE NECESSARY ROWS FROM K-SIGMA*M RSTART = RWSTRT(L) DO 110 I = L+1, MIN0(L+UNROLL-1,N) RSTART = MAX0(RSTART,RWSTRT(I)) 110 CONTINUE IF ((RSTART-L.LT.12).OR.(UPTO-L.LT.UNROLL)) THEN RSTART = RWSTRT(L) TNROLL = 1 ELSE TNROLL = UNROLL ENDIF * SET ALL THE ROWPTR'S (WE DO THIS HERE FOR PARALLELISM) DO 115 I = UPTO+1, RSTART ROWPTR(I) = NEXT NEXT = NEXT + I-L+1 ROWPTR(I+1) = NEXT IF (NEXT.GT.MXSIZE) THEN PRINT *,'ERROR: B-K FACTORIZATION OUT OF SPACE', C ' AT STEP ',L,' OF ',N,NEXT,MXSIZE,INERT STOP ENDIF 115 CONTINUE DO 120 I = UPTO+1, RSTART DO 130 J = ROWPTR(I),ROWPTR(I+1)-1 A(J) = 0.0D0 130 CONTINUE START = ROWPTR(I)+I DO 140 J = KRP(I), KRP(I+1)-1 A(START-KCP(J)) = K(J) 140 CONTINUE CNORECUR DO 150 J = MRP(I), MRP(I+1)-1 A(START-MCP(J)) = A(START-MCP(J)) - SIGMA*M(J) 150 CONTINUE * FIND THE LAMBDA'S IN THE NEW DATA VL(I) = A(ROWPTR(I)+I-L) IF (LAMBDA(1,ME).LT.ABS(VL(I))) THEN TR(ME) = I LAMBDA(1,ME) = ABS(VL(I)) ENDIF IF (TNROLL.GT.1) THEN VL2(I) = A(ROWPTR(I)+I-(L+1)) LAMBDA(2,ME) = MAX(LAMBDA(2,ME),ABS(VL2(I))) ENDIF 120 CONTINUE UPTO = MAX0(UPTO,RSTART) * DETERMINE WHAT SIZE PIVOT TO USE * FIRST, FIND LAMBDA OF COLUMN L, AND PUT COLUMN L IN V R = TR(1) DO 200 I = 2, NPROCS IF (LAMBDA(1,I).GT.LAMBDA(1,1)) THEN R = TR(I) LAMBDA(1,1) = LAMBDA(1,I) ENDIF 200 CONTINUE IF (TNROLL.GT.1) THEN DO 210 I = 2, NPROCS LAMBDA(2,1) = MAX(LAMBDA(2,1),LAMBDA(2,I)) 210 CONTINUE ENDIF * IF LAMBDA IS NOT ZERO THEN TRY TO DETERMINE WHAT * SIZE PIVOT TO USE IF (LAMBDA(1,1).NE.0.0D0) THEN * CHECK THE GROWTH RATE FOR A 1X1 PAVAL = A(ROWPTR(L)) IF (PAVAL.EQ.0.0D0) GOTO 300 PCVAL = A(ROWPTR(L+1)) LRATIO = ABS(LAMBDA(1,1)/PAVAL) GRATE1 = 1.0D0 + LRATIO * GROWTH RATE OF 1X1 IS TOO BIG, DO A MU SEARCH IF (GRATE1.GT.SLVLM) GOTO 300 * DO A STANDARD B-K PIVOT CHECK IF PCVAL IS 0 * OR IF WE ARE NEAR THE END OF THE FACTORIZATION IF ((PCVAL.EQ.0.0D0).OR.(UPTO-L.LT.12).OR. C (TNROLL.EQ.1)) GOTO 264 * FIND THE 2X2 GROWTH RATE TBVAL = A(ROWPTR(L+1)+1) PBVAL = TBVAL/PAVAL PCVAL = PCVAL - (PBVAL*TBVAL) TLAM2 = ABS(PBVAL)*LAMBDA(1,1)+LAMBDA(2,1) GRATE2 = GRATE1*(1.0D0+TLAM2/ABS(PCVAL)) * DO A PRELIMINARY CHECK ON GRATE2, IF IT IS TOO LARGE * ALREADY FOR A 6X6 THEN JUST GO THE 1X1 TEST IF ((GRATE2.GT.SLVLM).OR.(LAMBDA(2,1).EQ.0.0D0)) C GOTO 264 GOTO 263 263 CONTINUE * TRY TO DO A 2X2 PIVOT IF (GRATE2.LE.SLVL2) THEN GOTO 600 ENDIF 264 CONTINUE * TRY TO USE A(L,L) FOR A 1 X 1 PIVOT IF (GRATE1.LE.SLVL1) THEN GOTO 400 ENDIF * END OF PIVOT SIZE DETERMINATION * OTHERWISE WE FALL THROUGH AND SEARCH FOR MU ELSE * THIS ELSE STATEMENT CORRESPONDS WITH LAMBDA=0 * 0X0 PIVOT GOTO 750 * END OF 0 PIVOT ENDIF 300 CONTINUE * MU SEARCH * DIDN'T PASS ABOVE TESTS, NOW WE MUST FIND SIGMA * CALLED MU HERE TO AVOID CONFUSION WITH OTHER SIGMA * FIRST SEARCH ROW R, THEN COLUMN R TO DETERMINE MU MU = 0.0D0 DO 310 I = ROWPTR(R), ROWPTR(R)+(R-L)-1 MU = MAX(ABS(A(I)),MU) 310 CONTINUE TMPMAX = MAX0(UPTO,RWSTRT(R)) IF (UPTO.LT.RWSTRT(R)) THEN DO 320 I = UPTO+1, TMPMAX V(I) = 0.0D0 320 CONTINUE DO 330 I = CKRP(R), CKRP(R+1)-1 V(CKCP(I)) = CKOFF(I) 330 CONTINUE CNORECUR DO 340 I = CMRP(R), CMRP(R+1)-1 J = CMCP(I) V(J) = V(J) - SIGMA*CMOFF(I) 340 CONTINUE ENDIF DO 350 I = R+1, UPTO V(I) = A(ROWPTR(I)+I-R) 350 CONTINUE DO 360 I = R+1, TMPMAX MU = MAX(MU,ABS(V(I))) 360 CONTINUE * END OF MU SEARCH * NOW CHECK TO SEE IF WE CAN STILL USE A(L,L) AS THE PIVOT IF (CRIT*LAMBDA(1,1)*LAMBDA(1,1).LE. C MU*ABS(A(ROWPTR(L)))) THEN * GO AHEAD AND USE A(L,L) AND DO THE 1X1 PIVOT GOTO 400 ELSE GOTO 450 ENDIF 400 CONTINUE * THE 1X1 PIVOT IUPTO(L) = UPTO DIAG(L) = 1.0D0/A(ROWPTR(L)) IF (DIAG(L).LT.0.0D0) THEN INERT = INERT + 1 ENDIF A(ROWPTR(L)) = 1.0D0 SUBDAG(L+1) = 0.0D0 P(L) = 3 AT = DIAG(L) * COMPUTE THE PIVOT ROW CNORECUR DO 410 I = L+1, UPTO V(I) = VL(I) 410 CONTINUE * UPDATE THE ROWS BELOW DO 420 I = L+1, UPTO T = V(I) * AT START = ROWPTR(I)+I A(START-L) = T DO 430 J = L+1, I A(START-J) = A(START-J) - T*V(J) 430 CONTINUE 420 CONTINUE NSKIP = 0 GOTO 101 * END OF 1X1 PIVOT 450 CONTINUE * CHANGE MATRIX FOR BUNCH-KAUFMAN'S 2X2 PIVOT * DIDN'T PASS ABOVE TESTS, SO NOW WE MUST DO A 2X2 * FIRST, INTERCHANGE ROWS AND COLUMNS L+1 AND R * READ THE NECESSARY ROWS FROM K-SIGMA*M * AND ALLOW FOR THE FILL-IN IF (DEBUG.GT.1) THEN PRINT *,'FILLING IN ',RWSTRT(R)-UPTO,' AT ',L,R,UPTO ENDIF * IF WE DIDN'T EVEN TRY TO LOOK AT A 2X2 THEN FILL VL2 IF (TNROLL.EQ.1) THEN DO 453 I = L+1, UPTO VL2(I) = A(ROWPTR(I)+I-(L+1)) 453 CONTINUE ENDIF * GET ALL THE NECESSARY ROWS FROM K-SIGMA*M DO 454 I = UPTO+1, RWSTRT(R) ROWPTR(I) = NEXT NEXT = NEXT + I-L+1 ROWPTR(I+1) = NEXT IF (NEXT.GT.MXSIZE) THEN PRINT *,'ERROR: B-K FACTORIZATION OUT OF SPACE', C ' AT STEP ',L,' OF ',N,NEXT,MXSIZE,INERT STOP ENDIF 454 CONTINUE DO 455 I = UPTO+1, RWSTRT(R) DO 460 J = ROWPTR(I),ROWPTR(I+1)-1 A(J) = 0.0D0 460 CONTINUE START = ROWPTR(I)+I DO 470 J = KRP(I), KRP(I+1)-1 A(START-KCP(J)) = K(J) 470 CONTINUE CNORECUR DO 480 J = MRP(I), MRP(I+1)-1 A(START-MCP(J)) = A(START-MCP(J)) - SIGMA*M(J) 480 CONTINUE * SWITCH COLUMN L+1 AND R IN THIS NEW ROW (I) * PUTTING COLUMN L+1 INTO V2 V2(I) = A(START-R) A(START-R) = A(START-(L+1)) 455 CONTINUE * TACK ON ANY NECESSARY TRAILING 0'S TO V DO 490 I = UPTO+1, RWSTRT(R) VL(I) = 0.0D0 490 CONTINUE * SWITCH COLUMN L+1 AND R IN ROWS FROM R+1 TO UPTO CNORECUR DO 500 I = R+1, UPTO IADDR = ROWPTR(I)+I V2(I) = A(IADDR-R) A(IADDR-R) = VL2(I) 500 CONTINUE UPTO = MAX0(UPTO,RWSTRT(R)) IADDR = ROWPTR(R)+R * ROW AND COLUMN SWITCH IN ROWS L+2 TO R-1 CNORECUR DO 510 I = L+2, R-1 V2(I) = A(IADDR-I) A(IADDR-I) = VL2(I) 510 CONTINUE * SWITCH A(L+1,L+1) WITH A(R,R) V2(L+1) = A(ROWPTR(R)) A(ROWPTR(R)) = VL2(L+1) * FIX UP THE V VECTOR SO THAT IT CONTAINS COLUMN L * EFFECTIVELY SWITCH A(L+1,L) WITH A(R,L) T = VL(L+1) VL(L+1) = VL(R) VL(R) = T * END OF MATRIX CHANGES * BUNCH-KAUFMAN 2X2 PIVOT STEP * LOAD V2(R) V2(R) = VL2(R) INERT = INERT + 1 P(L) = 2 P(L+1) = -R T1 = VL(L) T2 = V2(L+1) T3 = VL(L+1) IUPTO(L) = UPTO IUPTO(L+1) = UPTO * COMPUTE THE INVERSE OF THE 2X2 PIVOT DETERM = ((((T1*T2)/T3)-T3)*T3) A11 = T2/DETERM A22 = T1/DETERM A21 = -T3/DETERM DIAG(L) = A11 DIAG(L+1) = A22 SUBDAG(L+1) = A21 SUBDAG(L+2) = 0.0D0 A(ROWPTR(L)) = 1.0D0 A(ROWPTR(L+1)) = 1.0D0 A(ROWPTR(L+1)+1) = 0.0D0 * COMPUTE THE TWO PIVOT ROWS CNORECUR DO 570 I = L+2, UPTO V(I) = VL(I) 570 CONTINUE * UPDATE THE ROWS BELOW CNORECUR DO 579 I = L+2, UPTO START = ROWPTR(I)+I VL(I) = V(I)*A11 + V2(I)*A21 A(START-L) = VL(I) VL2(I) = V(I)*A21 + V2(I)*A22 A(START-(L+1)) = VL2(I) 579 CONTINUE DO 580 I = L+2, UPTO START = ROWPTR(I)+I T = VL(I) T1 = VL2(I) CNORECUR DO 590 J = L+2, I A(START-J) = A(START-J) - T*V(J) - T1*V2(J) 590 CONTINUE 580 CONTINUE NSKIP = 1 GOTO 101 * END OF BUNCH-KAUFMAN 2X2 PIVOT STEP 600 CONTINUE * 2X2 PIVOT IUPTO(L) = UPTO IUPTO(L+1) = UPTO P(L) = 4 P(L+1) = 4 DIAG(L) = 1.0D0/PAVAL DIAG(L+1) = 1.0D0/PCVAL IF (PAVAL.LT.0.0D0) THEN INERT = INERT + 1 ENDIF IF (PCVAL.LT.0.0D0) THEN INERT = INERT + 1 ENDIF A(ROWPTR(L)) = 1.0D0 A(ROWPTR(L+1)) = 1.0D0 SUBDAG(L+1) = 0.0D0 SUBDAG(L+2) = 0.0D0 AT = DIAG(L) AT1 = DIAG(L+1) A(ROWPTR(L+1)+1) = PBVAL CNORECUR DO 610 I = L+2, UPTO V(I) = VL(I) V2(I) = VL2(I) - VL(I)*PBVAL 610 CONTINUE DO 620 I = L+2, UPTO START = ROWPTR(I)+I T = V(I)*AT A(START-L) = T T1 = V2(I)*AT1 A(START-(L+1)) = T1 DO 630 J = L+2, I A(START-J) = A(START-J) - T*V(J) - T1*V2(J) 630 CONTINUE 620 CONTINUE NSKIP = 1 GOTO 101 * END OF 2X2 PIVOT STEP 650 CONTINUE * END OF 3X3 PIVOT STEP 700 CONTINUE * END OF 4X4 PIVOT STEP 1000 CONTINUE * END OF 5X5 PIVOT STEP 1050 CONTINUE * END OF 6X6 PIVOT STEP 750 CONTINUE * EMPTY PIVOT STEP DIAG(L) = 1.0D0 / A(ROWPTR(L)) IF (DIAG(L).LT.0.0D0) THEN INERT = INERT + 1 ENDIF SUBDAG(L+1) = 0.0D0 A(ROWPTR(L)) = 1.0D0 P(L) = 1 IUPTO(L) = L GOTO 101 * END OF EMPTY PIVOT STEP 101 CONTINUE START = L + NSKIP + 1 DO 5000 I = 1, UNROLL LAMBDA(I,ME) = 0.0 5000 CONTINUE TNROLL = MAX0(0,UPTO-START) TNROLL = MIN0(UNROLL,TNROLL) IF (TNROLL.EQ.0) GOTO 102 * FIND NEXT LAMBDA(1) NSTART = START + (ME-1) IF (ME.EQ.1) THEN VL(NSTART) = A(ROWPTR(NSTART)) NSTART = NSTART + NPROCS ENDIF DO 5010 I = NSTART, UPTO, NPROCS VL(I) = A(ROWPTR(I)+I-START) 5010 CONTINUE TR(ME) = IGETMX(NSTART,UPTO,NPROCS,VL,LAMBDA(1,ME)) GOTO (102,5100,5200,5300,5400,5500) TNROLL 5100 CONTINUE IF (NSTART.EQ.START+1) THEN VL2(NSTART) = A(ROWPTR(NSTART)) NSTART = NSTART + NPROCS ENDIF DO 5110 I = NSTART, UPTO, NPROCS VL2(I) = A(ROWPTR(I)+I-(START+1)) LAMBDA(2,ME) = MAX(LAMBDA(2,ME),ABS(VL2(I))) 5110 CONTINUE GOTO 102 5200 CONTINUE 5300 CONTINUE 5400 CONTINUE 5500 CONTINUE 102 CONTINUE 100 CONTINUE * TIME FACTORIZATION INTERNALLY IF (DEBUG.EQ.-2) THEN CALL L2TMOF() PRINT *,'TIME FOR FACTORIZATION = ',LOCAL2() ENDIF IF (DEBUG.GT.1) THEN PRINT *,'USED ',NEXT-1,' OUT OF ',MXSIZE PRINT *,'INERTIA = ',INERT,' WITH SIGMA = ',SIGMA ENDIF * COMBINE EQUAL LENGTH ROWS FOR THE SOLVES I = 1 ICMAX = 10 * GOTO 1598 1500 CONTINUE GOTO (1501,1502,1503,1504,1505,1506,1507,1508,1529,1530) P(I) * EMPTY DON'T COMBINE 1501 CONTINUE I = I + 1 GOTO 1509 * B-K DON'T COMBINE 1502 CONTINUE I = I + 2 GOTO 1509 * 1X1 1503 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+1)).AND.(P(I+1).LT.ICMAX).AND. C (P(I+1).GE.3)) THEN P(I) = P(I) + (P(I+1)-2) CDIR$ NOVECTOR DO 1510 J = I+1, I+P(I)-3 P(J) = P(I) 1510 CONTINUE CDIR$ VECTOR ELSE I = I + 1 ENDIF GOTO 1509 * 2X2 1504 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+2)).AND.(P(I+2).LT.ICMAX-1).AND. C (P(I+2).GE.3)) THEN P(I) = P(I) + (P(I+2)-2) CDIR$ NOVECTOR DO 1511 J = I+1, I+P(I)-3 P(J) = P(I) 1511 CONTINUE CDIR$ VECTOR ELSE I = I + 2 ENDIF GOTO 1509 * 3X3 1505 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+3)).AND.(P(I+3).LT.ICMAX-2).AND. C (P(I+3).GE.3)) THEN P(I) = P(I) + (P(I+3)-2) CDIR$ NOVECTOR DO 1512 J = I+1, I+P(I)-3 P(J) = P(I) 1512 CONTINUE CDIR$ VECTOR ELSE I = I + 3 ENDIF GOTO 1509 * 4X4 1506 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+4)).AND.(P(I+4).LT.ICMAX-3).AND. C (P(I+4).GE.3)) THEN P(I) = P(I) + (P(I+4)-2) CDIR$ NOVECTOR DO 1513 J = I+1, I+P(I)-3 P(J) = P(I) 1513 CONTINUE CDIR$ VECTOR ELSE I = I + 4 ENDIF GOTO 1509 * 5X5 1507 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+5)).AND.(P(I+5).LT.ICMAX-4).AND. C (P(I+5).GE.3)) THEN P(I) = P(I) + (P(I+5)-2) CDIR$ NOVECTOR DO 1514 J = I+1, I+P(I)-3 P(J) = P(I) 1514 CONTINUE CDIR$ VECTOR ELSE I = I + 5 ENDIF GOTO 1509 * 6X6 1508 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+6)).AND.(P(I+6).LT.ICMAX-5).AND. C (P(I+6).GE.3)) THEN P(I) = P(I) + (P(I+6)-2) CDIR$ NOVECTOR DO 1515 J = I+1, I+P(I)-3 P(J) = P(I) 1515 CONTINUE CDIR$ VECTOR ELSE I = I + 6 ENDIF GOTO 1509 * 7X7 1529 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+7)).AND.(P(I+7).LT.ICMAX-6).AND. C (P(I+7).GE.3)) THEN P(I) = P(I) + (P(I+7)-2) CDIR$ NOVECTOR DO 1516 J = I+1, I+P(I)-3 P(J) = P(I) 1516 CONTINUE CDIR$ VECTOR ELSE I = I + 7 ENDIF GOTO 1509 * 8X8 1530 CONTINUE IF ((IUPTO(I).EQ.IUPTO(I+8)).AND.(P(I+8).LT.ICMAX-7).AND. C (P(I+8).GE.3)) THEN P(I) = P(I) + (P(I+8)-2) CDIR$ NOVECTOR DO 1517 J = I+1, I+P(I)-3 P(J) = P(I) 1517 CONTINUE CDIR$ VECTOR ELSE I = I + 8 ENDIF GOTO 1509 1509 CONTINUE IF (I.LT.N-(ICMAX-2)) GOTO 1500 *1598 CONTINUE IF (DEBUG.GE.2) THEN IT1 = 0 IT2 = 0 IT3 = 0 IT4 = 0 IT5 = 0 IT6 = 0 IT7 = 0 IT8 = 0 DO 1599 I = 1, N IF (P(I).EQ.3) THEN IT1 = IT1 + 1 ELSE IF (P(I).EQ.4) THEN IT2 = IT2 + 1 ELSE IF (P(I).EQ.5) THEN IT3 = IT3 + 1 ELSE IF (P(I).EQ.6) THEN IT4 = IT4 + 1 ELSE IF (P(I).EQ.7) THEN IT5 = IT5 + 1 ELSE IF (P(I).EQ.8) THEN IT6 = IT6 + 1 ELSE IF (P(I).EQ.9) THEN IT7 = IT7 + 1 ELSE IF (P(I).EQ.10) THEN IT8 = IT8 + 1 ENDIF 1599 CONTINUE PRINT *,'COMB 1 = ',IT1 PRINT *,'COMB 2 = ',IT2/2 PRINT *,'COMB 3 = ',IT3/3 PRINT *,'COMB 4 = ',IT4/4 PRINT *,'COMB 5 = ',IT5/5 PRINT *,'COMB 6 = ',IT6/6 PRINT *,'COMB 7 = ',IT7/7 PRINT *,'COMB 8 = ',IT8/8 ENDIF ENDIF IF (INFLAG.EQ.6) THEN RETURN ENDIF * TIME THE FORWARD SOLVE INTERNALLY IF (DEBUG.EQ.-2) THEN CALL L2TMON() ENDIF CALL CPYVEC(N,V,B) * SOLVE P(T)L V = B * DO 810 I = 1, N I = 1 810 CONTINUE IF (I.GT.N) GOTO 849 GOTO (811,812,813,814,815,816,817,818,819,820) P(I) 811 CONTINUE * A 0X0 PIVOT GOTO 831 812 CONTINUE * A B-K 2X2 PIVOT L = -P(I+1) T = V(L) V(L) = V(I+1) V(I+1) = T - A(ROWPTR(I+1)+1)*V(I) GOTO 834 813 CONTINUE * A 1X1 PIVOT GOTO 833 814 CONTINUE * A 2X2 PIVOT V(I+1) = V(I+1) - A(ROWPTR(I+1)+1)*V(I) GOTO 834 815 CONTINUE * A 3X3 PIVOT V(I+1) = V(I+1) - A(ROWPTR(I+1)+1)*V(I) V(I+2) = V(I+2) - A(ROWPTR(I+2)+2)*V(I) - C A(ROWPTR(I+2)+1)*V(I+1) GOTO 835 816 CONTINUE * A 4X4 PIVOT V(I+1) = V(I+1) - A(ROWPTR(I+1)+1)*V(I) V(I+2) = V(I+2) - A(ROWPTR(I+2)+2)*V(I) - C A(ROWPTR(I+2)+1)*V(I+1) V(I+3) = V(I+3) - A(ROWPTR(I+3)+3)*V(I) - C A(ROWPTR(I+3)+2)*V(I+1) - A(ROWPTR(I+3)+1)*V(I+2) GOTO 836 817 CONTINUE * A 5X5 PIVOT V(I+1) = V(I+1) - A(ROWPTR(I+1)+1)*V(I) V(I+2) = V(I+2) - A(ROWPTR(I+2)+2)*V(I) - C A(ROWPTR(I+2)+1)*V(I+1) V(I+3) = V(I+3) - A(ROWPTR(I+3)+3)*V(I) - C A(ROWPTR(I+3)+2)*V(I+1) - A(ROWPTR(I+3)+1)*V(I+2) V(I+4) = V(I+4) - A(ROWPTR(I+4)+4)*V(I) - C A(ROWPTR(I+4)+3)*V(I+1) - A(ROWPTR(I+4)+2)*V(I+2) - C A(ROWPTR(I+4)+1)*V(I+3) GOTO 837 818 CONTINUE * A 6X6 PIVOT V(I+1) = V(I+1) - A(ROWPTR(I+1)+1)*V(I) V(I+2) = V(I+2) - A(ROWPTR(I+2)+2)*V(I) - C A(ROWPTR(I+2)+1)*V(I+1) V(I+3) = V(I+3) - A(ROWPTR(I+3)+3)*V(I) - C A(ROWPTR(I+3)+2)*V(I+1) - A(ROWPTR(I+3)+1)*V(I+2) V(I+4) = V(I+4) - A(ROWPTR(I+4)+4)*V(I) - C A(ROWPTR(I+4)+3)*V(I+1) - A(ROWPTR(I+4)+2)*V(I+2) - C A(ROWPTR(I+4)+1)*V(I+3) V(I+5) = V(I+5) - A(ROWPTR(I+5)+5)*V(I) - C A(ROWPTR(I+5)+4)*V(I+1) - A(ROWPTR(I+5)+3)*V(I+2) - C A(ROWPTR(I+5)+2)*V(I+3) - A(ROWPTR(I+5)+1)*V(I+4) GOTO 838 819 CONTINUE * A 7X7 PIVOT V(I+1) = V(I+1) - A(ROWPTR(I+1)+1)*V(I) V(I+2) = V(I+2) - A(ROWPTR(I+2)+2)*V(I) - C A(ROWPTR(I+2)+1)*V(I+1) V(I+3) = V(I+3) - A(ROWPTR(I+3)+3)*V(I) - C A(ROWPTR(I+3)+2)*V(I+1) - A(ROWPTR(I+3)+1)*V(I+2) V(I+4) = V(I+4) - A(ROWPTR(I+4)+4)*V(I) - C A(ROWPTR(I+4)+3)*V(I+1) - A(ROWPTR(I+4)+2)*V(I+2) - C A(ROWPTR(I+4)+1)*V(I+3) V(I+5) = V(I+5) - A(ROWPTR(I+5)+5)*V(I) - C A(ROWPTR(I+5)+4)*V(I+1) - A(ROWPTR(I+5)+3)*V(I+2) - C A(ROWPTR(I+5)+2)*V(I+3) - A(ROWPTR(I+5)+1)*V(I+4) V(I+6) = V(I+6) - A(ROWPTR(I+6)+6)*V(I) - C A(ROWPTR(I+6)+5)*V(I+1) - A(ROWPTR(I+6)+4)*V(I+2) - C A(ROWPTR(I+6)+3)*V(I+3) - A(ROWPTR(I+6)+2)*V(I+4) - C A(ROWPTR(I+6)+1)*V(I+5) GOTO 839 820 CONTINUE * A 8X8 PIVOT V(I+1) = V(I+1) - A(ROWPTR(I+1)+1)*V(I) V(I+2) = V(I+2) - A(ROWPTR(I+2)+2)*V(I) - C A(ROWPTR(I+2)+1)*V(I+1) V(I+3) = V(I+3) - A(ROWPTR(I+3)+3)*V(I) - C A(ROWPTR(I+3)+2)*V(I+1) - A(ROWPTR(I+3)+1)*V(I+2) V(I+4) = V(I+4) - A(ROWPTR(I+4)+4)*V(I) - C A(ROWPTR(I+4)+3)*V(I+1) - A(ROWPTR(I+4)+2)*V(I+2) - C A(ROWPTR(I+4)+1)*V(I+3) V(I+5) = V(I+5) - A(ROWPTR(I+5)+5)*V(I) - C A(ROWPTR(I+5)+4)*V(I+1) - A(ROWPTR(I+5)+3)*V(I+2) - C A(ROWPTR(I+5)+2)*V(I+3) - A(ROWPTR(I+5)+1)*V(I+4) V(I+6) = V(I+6) - A(ROWPTR(I+6)+6)*V(I) - C A(ROWPTR(I+6)+5)*V(I+1) - A(ROWPTR(I+6)+4)*V(I+2) - C A(ROWPTR(I+6)+3)*V(I+3) - A(ROWPTR(I+6)+2)*V(I+4) - C A(ROWPTR(I+6)+1)*V(I+5) V(I+7) = V(I+7) - A(ROWPTR(I+7)+7)*V(I) - C A(ROWPTR(I+7)+6)*V(I+1) - A(ROWPTR(I+7)+5)*V(I+2) - C A(ROWPTR(I+7)+4)*V(I+3) - A(ROWPTR(I+7)+3)*V(I+4) - C A(ROWPTR(I+7)+2)*V(I+5) - A(ROWPTR(I+7)+1)*V(I+6) GOTO 840 831 CONTINUE * A 0X0 PIVOT I = I + 1 GOTO 810 833 CONTINUE * A 1X1 PIVOT CNORECUR DO 841 J = I+1, IUPTO(I) V(J) = V(J) - A(ROWPTR(J)+J-I)*V(I) 841 CONTINUE I = I + 1 GOTO 810 834 CONTINUE * A 2X2 PIVOT CNORECUR DO 842 J = I+2, IUPTO(I) IADDR = ROWPTR(J)+J-I V(J) = V(J) - A(IADDR)*V(I) - A(IADDR-1)*V(I+1) 842 CONTINUE I = I + 2 GOTO 810 835 CONTINUE * A 3X3 PIVOT CNORECUR DO 843 J = I+3, IUPTO(I) IADDR = ROWPTR(J)+J-I V(J) = V(J) - A(IADDR)*V(I) - A(IADDR-1)*V(I+1) - C A(IADDR-2)*V(I+2) 843 CONTINUE I = I + 3 GOTO 810 836 CONTINUE * A 4X4 PIVOT CNORECUR DO 844 J = I+4, IUPTO(I) IADDR = ROWPTR(J)+J-I V(J) = V(J) - A(IADDR)*V(I) - A(IADDR-1)*V(I+1) - C A(IADDR-2)*V(I+2) - A(IADDR-3)*V(I+3) 844 CONTINUE I = I + 4 GOTO 810 837 CONTINUE * A 5X5 PIVOT CNORECUR DO 845 J = I+5, IUPTO(I) IADDR = ROWPTR(J)+J-I V(J) = V(J) - A(IADDR)*V(I) - A(IADDR-1)*V(I+1) - C A(IADDR-2)*V(I+2) - A(IADDR-3)*V(I+3) - A(IADDR-4)*V(I+4) 845 CONTINUE I = I + 5 GOTO 810 838 CONTINUE * A 6X6 PIVOT CNORECUR DO 846 J = I+6, IUPTO(I) IADDR = ROWPTR(J)+J-I V(J) = V(J) - A(IADDR)*V(I) - A(IADDR-1)*V(I+1) - C A(IADDR-2)*V(I+2) - C A(IADDR-3)*V(I+3) - A(IADDR-4)*V(I+4) - A(IADDR-5)*V(I+5) 846 CONTINUE I = I + 6 GOTO 810 839 CONTINUE * A 7X7 PIVOT CNORECUR DO 847 J = I+7, IUPTO(I) IADDR = ROWPTR(J)+J-I V(J) = V(J) - A(IADDR)*V(I) - A(IADDR-1)*V(I+1) - C A(IADDR-2)*V(I+2) - C A(IADDR-3)*V(I+3) - A(IADDR-4)*V(I+4) - A(IADDR-5)*V(I+5) - C A(IADDR-6)*V(I+6) 847 CONTINUE I = I + 7 GOTO 810 840 CONTINUE * A 8X8 PIVOT CNORECUR DO 848 J = I+8, IUPTO(I) IADDR = ROWPTR(J)+J-I V(J) = V(J) - A(IADDR)*V(I) - A(IADDR-1)*V(I+1) - C A(IADDR-2)*V(I+2) - C A(IADDR-3)*V(I+3) - A(IADDR-4)*V(I+4) - A(IADDR-5)*V(I+5) - C A(IADDR-6)*V(I+6) - A(IADDR-7)*V(I+7) 848 CONTINUE I = I + 8 GOTO 810 * END OF FORWARD SOLVE 849 CONTINUE * TIME FORWARD SOLVE INTERNALLY IF (DEBUG.EQ.-2) THEN CALL L2TMOF() PRINT *,'TIME FOR FORWARD SOLVE = ',LOCAL2() ENDIF * SOLVE D U = V X(1) = DIAG(1)*V(1)+SUBDAG(2)*V(2) X(N) = DIAG(N)*V(N)+SUBDAG(N)*V(N-1) DO 850 I = 2, N-1 X(I) = DIAG(I)*V(I)+SUBDAG(I)*V(I-1)+SUBDAG(I+1)*V(I+1) 850 CONTINUE * TIME THE BACKWARD SOLVE INTERNALLY IF (DEBUG.EQ.-2) THEN CALL L2TMON() ENDIF * SOLVE L(T)*P X = V * DO 860 I = N, 1, -1 I = N 860 CONTINUE IF (I.LE.0) GOTO 880 IF (P(I).LE.1) THEN IF (P(I).LT.0) THEN NUMROW = 2 ELSE I = I - 1 GOTO 860 ENDIF ELSE NUMROW = P(I) - 2 ENDIF IF (NUMROW.GE.NPROCS) THEN MYNUM = NUMROW / NPROCS ISTART = MYNUM * (ME-1) IF (ME.LE.MOD(NUMROW,NPROCS)) THEN MYNUM = MYNUM + 1 ISTART = ISTART + (ME-1) ELSE ISTART = ISTART + MOD(NUMROW,NPROCS) ENDIF GOTO (861,862,863,864,865,866,867,868) MYNUM GOTO 879 ELSE ISTART = MOD((ME-1),NUMROW) IMULT = NPROCS / NUMROW IF (ISTART.LT.MOD(NPROCS,NUMROW)) THEN IMULT = IMULT + 1 ENDIF IOFF = (ME-1) / NUMROW IF (IMULT.EQ.1) THEN GOTO 861 ELSE GOTO 869 ENDIF ENDIF 861 CONTINUE * A 1X1 PIVOT T = X(I-ISTART) DO 871 J = I+1, IUPTO(I) T = T - A(ROWPTR(J)+J-I+ISTART)*X(J) 871 CONTINUE X(I-ISTART) = T GOTO 879 * END OF 1X1 862 CONTINUE * A NORMAL 2X2 PIVOT T = X(I-ISTART) T1 = X(I-ISTART-1) DO 872 J = I+1, IUPTO(I) IADDR = ROWPTR(J)+J-I+ISTART TX = X(J) T = T - A(IADDR)*TX T1 = T1 - A(IADDR+1)*TX 872 CONTINUE X(I-ISTART) = T X(I-ISTART-1) = T1 GOTO 879 * END OF NORMAL 2X2 863 CONTINUE * A NORMAL 3X3 PIVOT T = X(I-ISTART) T1 = X(I-ISTART-1) T2 = X(I-ISTART-2) DO 873 J = I+1, IUPTO(I) IADDR = ROWPTR(J)+J-I+ISTART TX = X(J) T = T - A(IADDR)*TX T1 = T1 - A(IADDR+1)*TX T2 = T2 - A(IADDR+2)*TX 873 CONTINUE X(I-ISTART) = T X(I-ISTART-1) = T1 X(I-ISTART-2) = T2 GOTO 879 * END OF NORMAL 3X3 864 CONTINUE * A NORMAL 4X4 PIVOT T = X(I-ISTART) T1 = X(I-ISTART-1) T2 = X(I-ISTART-2) T3 = X(I-ISTART-3) DO 874 J = I+1, IUPTO(I) IADDR = ROWPTR(J)+J-I+ISTART TX = X(J) T = T - A(IADDR)*TX T1 = T1 - A(IADDR+1)*TX T2 = T2 - A(IADDR+2)*TX T3 = T3 - A(IADDR+3)*TX 874 CONTINUE X(I-ISTART) = T X(I-ISTART-1) = T1 X(I-ISTART-2) = T2 X(I-ISTART-3) = T3 GOTO 879 * END OF NORMAL 4X4 865 CONTINUE * A NORMAL 5X5 PIVOT T = X(I-ISTART) T1 = X(I-ISTART-1) T2 = X(I-ISTART-2) T3 = X(I-ISTART-3) T4 = X(I-ISTART-4) DO 875 J = I+1, IUPTO(I) IADDR = ROWPTR(J)+J-I+ISTART TX = X(J) T = T - A(IADDR)*TX T1 = T1 - A(IADDR+1)*TX T2 = T2 - A(IADDR+2)*TX T3 = T3 - A(IADDR+3)*TX T4 = T4 - A(IADDR+4)*TX 875 CONTINUE X(I-ISTART) = T X(I-ISTART-1) = T1 X(I-ISTART-2) = T2 X(I-ISTART-3) = T3 X(I-ISTART-4) = T4 GOTO 879 * END OF NORMAL 5X5 866 CONTINUE * A NORMAL 6X6 PIVOT T = X(I-ISTART) T1 = X(I-ISTART-1) T2 = X(I-ISTART-2) T3 = X(I-ISTART-3) T4 = X(I-ISTART-4) T5 = X(I-ISTART-5) DO 876 J = I+1, IUPTO(I) IADDR = ROWPTR(J)+J-I+ISTART TX = X(J) T = T - A(IADDR)*TX T1 = T1 - A(IADDR+1)*TX T2 = T2 - A(IADDR+2)*TX T3 = T3 - A(IADDR+3)*TX T4 = T4 - A(IADDR+4)*TX T5 = T5 - A(IADDR+5)*TX 876 CONTINUE X(I-ISTART) = T X(I-ISTART-1) = T1 X(I-ISTART-2) = T2 X(I-ISTART-3) = T3 X(I-ISTART-4) = T4 X(I-ISTART-5) = T5 GOTO 879 * END OF NORMAL 6X6 867 CONTINUE * A NORMAL 7X7 PIVOT T = X(I-ISTART) T1 = X(I-ISTART-1) T2 = X(I-ISTART-2) T3 = X(I-ISTART-3) T4 = X(I-ISTART-4) T5 = X(I-ISTART-5) T6 = X(I-ISTART-6) DO 877 J = I+1, IUPTO(I) IADDR = ROWPTR(J)+J-I+ISTART TX = X(J) T = T - A(IADDR)*TX T1 = T1 - A(IADDR+1)*TX T2 = T2 - A(IADDR+2)*TX T3 = T3 - A(IADDR+3)*TX T4 = T4 - A(IADDR+4)*TX T5 = T5 - A(IADDR+5)*TX T6 = T6 - A(IADDR+6)*TX 877 CONTINUE X(I-ISTART) = T X(I-ISTART-1) = T1 X(I-ISTART-2) = T2 X(I-ISTART-3) = T3 X(I-ISTART-4) = T4 X(I-ISTART-5) = T5 X(I-ISTART-6) = T6 GOTO 879 * END OF NORMAL 7X7 868 CONTINUE * A NORMAL 8X8 PIVOT T = X(I-ISTART) T1 = X(I-ISTART-1) T2 = X(I-ISTART-2) T3 = X(I-ISTART-3) T4 = X(I-ISTART-4) T5 = X(I-ISTART-5) T6 = X(I-ISTART-6) T7 = X(I-ISTART-7) DO 878 J = I+1, IUPTO(I) IADDR = ROWPTR(J)+J-I+ISTART TX = X(J) T = T - A(IADDR)*TX T1 = T1 - A(IADDR+1)*TX T2 = T2 - A(IADDR+2)*TX T3 = T3 - A(IADDR+3)*TX T4 = T4 - A(IADDR+4)*TX T5 = T5 - A(IADDR+5)*TX T6 = T6 - A(IADDR+6)*TX T7 = T7 - A(IADDR+7)*TX 878 CONTINUE X(I-ISTART) = T X(I-ISTART-1) = T1 X(I-ISTART-2) = T2 X(I-ISTART-3) = T3 X(I-ISTART-4) = T4 X(I-ISTART-5) = T5 X(I-ISTART-6) = T6 X(I-ISTART-7) = T7 GOTO 879 * END OF NORMAL 8X8 869 CONTINUE * A 1X1 PIVOT WITH MULTIPLE PROCESSORS T = 0.0D0 DO 889 J = I+1+IOFF, IUPTO(I), IMULT T = T + A(ROWPTR(J)+J-I+ISTART)*X(J) 889 CONTINUE X(I-ISTART) = X(I-ISTART) - T GOTO 879 * END OF 1X1 WITH MULTIPLE PROCESSORS 879 CONTINUE I = I - NUMROW II = I + NUMROW GOTO (8499,8502,8503,8504,8505,8506,8507,8508) NUMROW * 2X2 PIVOT 8502 CONTINUE X(II-1) = X(II-1) - A(ROWPTR(II)+1)*X(II) * MAKE A CORRECTION FOR B-K IF NECESSARY IF (P(II).NE.4) THEN L = -P(II) T = X(II) X(II) = X(L) X(L) = T ENDIF GOTO 8499 * 3X3 PIVOT 8503 CONTINUE X(II-1) = X(II-1) - A(ROWPTR(II)+1)*X(II) X(II-2) = X(II-2) - A(ROWPTR(II)+2)*X(II) - C A(ROWPTR(II-1)+1)*X(II-1) GOTO 8499 * 4X4 PIVOT 8504 CONTINUE X(II-1) = X(II-1) - A(ROWPTR(II)+1)*X(II) X(II-2) = X(II-2) - A(ROWPTR(II)+2)*X(II) - C A(ROWPTR(II-1)+1)*X(II-1) X(II-3) = X(II-3) - A(ROWPTR(II)+3)*X(II) - C A(ROWPTR(II-1)+2)*X(II-1) - A(ROWPTR(II-2)+1)*X(II-2) GOTO 8499 * 5X5 PIVOT 8505 CONTINUE X(II-1) = X(II-1) - A(ROWPTR(II)+1)*X(II) X(II-2) = X(II-2) - A(ROWPTR(II)+2)*X(II) - C A(ROWPTR(II-1)+1)*X(II-1) X(II-3) = X(II-3) - A(ROWPTR(II)+3)*X(II) - C A(ROWPTR(II-1)+2)*X(II-1) - A(ROWPTR(II-2)+1)*X(II-2) X(II-4) = X(II-4) - A(ROWPTR(II)+4)*X(II) - C A(ROWPTR(II-1)+3)*X(II-1) - A(ROWPTR(II-2)+2)*X(II-2) - C A(ROWPTR(II-3)+1)*X(II-3) GOTO 8499 8506 CONTINUE X(II-1) = X(II-1) - A(ROWPTR(II)+1)*X(II) X(II-2) = X(II-2) - A(ROWPTR(II)+2)*X(II) - C A(ROWPTR(II-1)+1)*X(II-1) X(II-3) = X(II-3) - A(ROWPTR(II)+3)*X(II) - C A(ROWPTR(II-1)+2)*X(II-1) - A(ROWPTR(II-2)+1)*X(II-2) X(II-4) = X(II-4) - A(ROWPTR(II)+4)*X(II) - C A(ROWPTR(II-1)+3)*X(II-1) - A(ROWPTR(II-2)+2)*X(II-2) - C A(ROWPTR(II-3)+1)*X(II-3) X(II-5) = X(II-5) - A(ROWPTR(II)+5)*X(II) - C A(ROWPTR(II-1)+4)*X(II-1) - A(ROWPTR(II-2)+3)*X(II-2) - C A(ROWPTR(II-3)+2)*X(II-3) - A(ROWPTR(II-4)+1)*X(II-4) GOTO 8499 8507 CONTINUE X(II-1) = X(II-1) - A(ROWPTR(II)+1)*X(II) X(II-2) = X(II-2) - A(ROWPTR(II)+2)*X(II) - C A(ROWPTR(II-1)+1)*X(II-1) X(II-3) = X(II-3) - A(ROWPTR(II)+3)*X(II) - C A(ROWPTR(II-1)+2)*X(II-1) - A(ROWPTR(II-2)+1)*X(II-2) X(II-4) = X(II-4) - A(ROWPTR(II)+4)*X(II) - C A(ROWPTR(II-1)+3)*X(II-1) - A(ROWPTR(II-2)+2)*X(II-2) - C A(ROWPTR(II-3)+1)*X(II-3) X(II-5) = X(II-5) - A(ROWPTR(II)+5)*X(II) - C A(ROWPTR(II-1)+4)*X(II-1) - A(ROWPTR(II-2)+3)*X(II-2) - C A(ROWPTR(II-3)+2)*X(II-3) - A(ROWPTR(II-4)+1)*X(II-4) X(II-6) = X(II-6) - A(ROWPTR(II)+6)*X(II) - C A(ROWPTR(II-1)+5)*X(II-1) - A(ROWPTR(II-2)+4)*X(II-2) - C A(ROWPTR(II-3)+3)*X(II-3) - A(ROWPTR(II-4)+2)*X(II-4) - C A(ROWPTR(II-5)+1)*X(II-5) GOTO 8499 8508 CONTINUE X(II-1) = X(II-1) - A(ROWPTR(II)+1)*X(II) X(II-2) = X(II-2) - A(ROWPTR(II)+2)*X(II) - C A(ROWPTR(II-1)+1)*X(II-1) X(II-3) = X(II-3) - A(ROWPTR(II)+3)*X(II) - C A(ROWPTR(II-1)+2)*X(II-1) - A(ROWPTR(II-2)+1)*X(II-2) X(II-4) = X(II-4) - A(ROWPTR(II)+4)*X(II) - C A(ROWPTR(II-1)+3)*X(II-1) - A(ROWPTR(II-2)+2)*X(II-2) - C A(ROWPTR(II-3)+1)*X(II-3) X(II-5) = X(II-5) - A(ROWPTR(II)+5)*X(II) - C A(ROWPTR(II-1)+4)*X(II-1) - A(ROWPTR(II-2)+3)*X(II-2) - C A(ROWPTR(II-3)+2)*X(II-3) - A(ROWPTR(II-4)+1)*X(II-4) X(II-6) = X(II-6) - A(ROWPTR(II)+6)*X(II) - C A(ROWPTR(II-1)+5)*X(II-1) - A(ROWPTR(II-2)+4)*X(II-2) - C A(ROWPTR(II-3)+3)*X(II-3) - A(ROWPTR(II-4)+2)*X(II-4) - C A(ROWPTR(II-5)+1)*X(II-5) X(II-7) = X(II-7) - A(ROWPTR(II)+7)*X(II) - C A(ROWPTR(II-1)+6)*X(II-1) - A(ROWPTR(II-2)+5)*X(II-2) - C A(ROWPTR(II-3)+4)*X(II-3) - A(ROWPTR(II-4)+3)*X(II-4) - C A(ROWPTR(II-5)+2)*X(II-5) - A(ROWPTR(II-6)+1)*X(II-6) GOTO 8499 8499 CONTINUE GOTO 860 * END OF BACKWARD SOLVE 880 CONTINUE * TIME BACKWARD SOLVE INTERNALLY IF (DEBUG.EQ.-2) THEN CALL L2TMOF() PRINT *,'TIME FOR BACKWARD SOLVE = ',LOCAL2() ENDIF RETURN END C$FORTRAN CHKFIN *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: CHKFIN.MSC * * AUTHOR: MARK JONES * * PURPOSE: DETERMINES IF ANY DESIRED EIGENVALUES HAVE BEEN * * MISSED BY LOOKING AT INERTIA COUNTS, UNCONVERGED * * AND CONVERGED EIGENVALUES * *********************************************************************** SUBROUTINE CHKFIN(N,OEIGNM,OTHETA,OLDBJ,R1LEN,R1THET,R1BJ, C R2LEN,R2THET,R2BJ,ONMSGT,OSIGMA,LFTVAL,RGTVAL, C NWLEFT,NWRGHT,DEBUG,KNORM,MNORM,EPS, C ATOL,ERRCHK,NMSGT,WORKV1,SRTTHT,THTIDX, C INTLST,SIGLST,INTIDX, C FALEAD,FA,FARP,FARL,FIWRKV,FRWRKV,PROB, C NROLL,KAUX,KRP,KCP,MAUX,MRP,MCP,FASIZE,FAADDR,TMEM, C KFORM,MFORM,FACTYP,WRKPTR,RETVAL,TSTATE,CBOUND,BLEFT,BRIGHT, C BFACT,MAXDLY,INSIZE,INPTR,INADDR) * THE ORDER OF THE MATRIX INTEGER N * THE NUMBER OF EIGENVALUES IN OTHETA INTEGER OEIGNM * THE CONVERGED EIGENVALUES DOUBLE PRECISION OTHETA(*) * THE ERROR BOUNDS OF THE CONVERGED EIGENVALUES DOUBLE PRECISION OLDBJ(*) * THE NUMBER OF EIGENVALUES IN THE R1THET INTEGER R1LEN * THE GROUP OF EIGENVALUES FROM THE R1 RUN DOUBLE PRECISION R1THET(*) * THE ERROR BOUNDS FOR THE R1 RUN DOUBLE PRECISION R1BJ(*) * THE NUMBER OF EIGENVALUES IN THE R2THET INTEGER R2LEN * THE GROUP OF EIGENVALUES FROM THE R2 RUN DOUBLE PRECISION R2THET(*) * THE ERROR BOUNDS FOR THE R2 RUN DOUBLE PRECISION R2BJ(*) * THE ORIGINAL NUMBER OF EIGENVALUES BEING SOUGHT INTEGER ONMSGT * THE ORIGINAL SHIFT BEING SEARCHED AROUND DOUBLE PRECISION OSIGMA * THE CURRENT LEFT SHIFT DOUBLE PRECISION LFTVAL * THE CURRENT RIGHT SHIFT DOUBLE PRECISION RGTVAL * DO WE HAVE A LEFT SHIFT LOGICAL NWLEFT * DO WE HAVE A RIGHT SHIFT LOGICAL NWRGHT * THE DEBUGGING VALUE INTEGER DEBUG * THE NORMS OF K AND M DOUBLE PRECISION KNORM, MNORM * THE MACHINE EPSILON DOUBLE PRECISION EPS * THE TOLERANCE NEEDED FOR EIGENVALUE ACCEPTANCE DOUBLE PRECISION ATOL * THE ERROR CHECKING LEVEL INTEGER ERRCHK * THE CURRENT NUMBER OF EIGENVALUES BEING SOUGHT INTEGER NMSGT * DOUBLE PRECISION WORK VECTOR DOUBLE PRECISION WORKV1(*) * THE EIGENVALUES IN SORTED ORDER DOUBLE PRECISION SRTTHT(*) * THE RANK OF THE EIGENVALUE IN DISTANCE FROM OSIGMA INTEGER THTIDX(*) * A LIST OF INERTIA CALCULATIONS INTEGER INTLST(*) * A LIST OF SIGMAS DOUBLE PRECISION SIGLST(*) * THE NUMBER OF SIGMAS AND INERTIA INTEGER INTIDX * THE ACCESSING INDEX FOR FA INTEGER FALEAD * STORAGE FOR THE FACTORED MATRIX DOUBLE PRECISION FA(*) * STORAGE FOR THE FACTORED MATRIX INTEGER FARP(*) * STORAGE FOR THE FACTORED MATRIX INTEGER FARL(*) * FACTORIZATION WORK VECTORS INTEGER FIWRKV(N+1,2) DOUBLE PRECISION FRWRKV(N,3) * VIBRATION (0) OR BUCKLING (1) INTEGER PROB * THE LEVEL OF LOOP UNROLLING INTEGER NROLL * THE STIFFNESS MATRIX DOUBLE PRECISION KAUX(*) * THE STIFFNESS MATRIX INTEGER KRP(*) * THE STIFFNESS MATRIX INTEGER KCP(*) * THE MASS MATRIX DOUBLE PRECISION MAUX(*) * THE MASS MATRIX INTEGER MRP(*) * THE MASS MATRIX INTEGER MCP(*) * THE SIZE OF FA INTEGER FASIZE * THE DOUBLE PRECISION ADDRESS OF FA INTEGER FAADDR * THE TOTAL MEMORY ALLOCATED INTEGER TMEM * THE FORM THAT K IS STORED IN INTEGER KFORM * THE FORM THAT M IS STORED IN INTEGER MFORM * THE TYPE OF FACTORIZATION INTEGER FACTYP * POINTER TO A FACTORIZATION WORK AREA INTEGER WRKPTR * SINCE THIS IS A PROCEDURE NOW, THIS IS THE RETURN VALUE INTEGER RETVAL * THE STATE WE ARE IN INTEGER TSTATE * BOUNDARIES? INTEGER CBOUND * THE RIGHT AND LEFT BOUNDARIES DOUBLE PRECISION BLEFT, BRIGHT * THE B-K STORAGE FACTOR DOUBLE PRECISION BFACT * THE MAXIMUM NUMBER OF DELAYED PIVOTS THAT CAN BE STORED INTEGER MAXDLY * SIZE OF INDICES INTO FACTORED MATRIX (FOR SPARSE FACTOR) INTEGER INSIZE * OFFSET ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INPTR * ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INADDR * INTERNAL VARIABLES * COUNT VARIABLES INTEGER I * DO WE DO A POST CHECK? LOGICAL PSTERR * DISTANCE BETWEEN FURTHEST EIGENVALUE AND OSIGMA DOUBLE PRECISION EIGBND * HAVE ENOUGH EIGENVALUES BEEN FOUND? LOGICAL DONE * IS EVERYTHING OKAY? LOGICAL OKAY * HAS A NEW SHIFT BEEN FOUND? LOGICAL SHTFND * MIN OF OEIGNUM AND ONMSGT INTEGER OINDX * THE RETURN VALUE FROM CHKGAP INTEGER CHKSTS * THE MISSING VALUE AND ITS ERROR BOUND DOUBLE PRECISION MISVAL, MISBJ * HAVE WE FINISHED CHECKING? LOGICAL FINCHK * UNRECOVERABLE ERROR? LOGICAL BADEND * NUMBER OF MISSING VALUES INTEGER MISSED * THE MINIMUM DIST. A SHIFT CAN BE FROM AN EIGENVALUE DOUBLE PRECISION MNDIST * TWO TEMPORARY VALUES DOUBLE PRECISION T1VAL, T2VAL * PARAMETER PASSED TO ADJSHT DOUBLE PRECISION FRACT * THE OLD RIGHT SHIFT DOUBLE PRECISION ORGTVL * DID WE HAVE AN OLD RIGHT SHIFT LOGICAL ONWRGT * INTEGER FUNCTIONS INTEGER SRCHLW, CHKGAP, GBOUND * IF NO EIGENVALUES OR NOT IN STATE 0 THEN RETURN IF (((OEIGNM.EQ.0).AND.(CBOUND.NE.1)).OR. C ((TSTATE.GT.0).AND.(TSTATE.LT.5))) THEN RETVAL = 1 RETURN ENDIF * INITIALIZE SOME VALUES ONWRGT = NWRGHT OKAY = .FALSE. SHTFND = .FALSE. FINCHK = .FALSE. BADEND = .FALSE. NWRGHT = .FALSE. ORGTVL = RGTVAL IF (CBOUND.EQ.1) THEN PSTERR = .FALSE. OINDX = OEIGNM DONE = .TRUE. ELSE * DO WE DO A POST TEST USING INERTIA? IF (ERRCHK.GE.1) THEN PSTERR = .TRUE. ELSE PSTERR = .FALSE. ENDIF * COULD WE BE FINISHED? IF (OEIGNM.GE.ONMSGT) THEN DONE = .TRUE. OINDX = ONMSGT ELSE DONE = .FALSE. OINDX = OEIGNM ENDIF * SEARCH FOR UNCONVERGED NEEDED EIGENVALUES MISSED = SRCHLW(OEIGNM,OTHETA,R1LEN,R1THET,R1BJ, C R2LEN,R2THET,R2BJ,OINDX,OSIGMA,WORKV1, C MISVAL,MISBJ,ATOL) IF (MISSED.GT.0) THEN FINCHK = .TRUE. RGTVAL = MISVAL NMSGT = MAX(OEIGNM + MISSED,NMSGT) NMSGT = MIN(NMSGT,N) IF (DEBUG.GT.0) THEN PRINT *,'MISSED = ',MISSED,OEIGNM,NMSGT ENDIF * ADJUST NEW RIGHT SHIFT MNDIST = (1.0D0/(ATOL/RGTVAL)) * C ((KNORM - (MNORM*RGTVAL))*EPS) MNDIST = MAX(MNDIST,0.001D0*RGTVAL) MNDIST = MIN(MNDIST,0.01D0*RGTVAL) T1VAL = RGTVAL T2VAL = MISBJ FRACT = 0.1D0 IF (DEBUG.GT.0) THEN PRINT *,'RIGHT VAL = ',RGTVAL,MISBJ PRINT *,'MIN DIST = ',MNDIST ENDIF CALL ADJSHT(RGTVAL,T1VAL,T2VAL,MNDIST,OSIGMA, C OEIGNM,OTHETA,OLDBJ,R1LEN,R1THET,R1BJ, C R2LEN,R2THET,R2BJ,FRACT) IF (DEBUG.GT.0) THEN PRINT *,'ADJUSTED RIGHT VAL = ',RGTVAL ENDIF IF (ONWRGT.AND.(ABS(ORGTVL-MISVAL).GT. C ABS(RGTVAL-MISVAL))) THEN NWRGHT = .TRUE. ELSE IF (NWLEFT.AND.(ABS(LFTVAL-MISVAL).GT. C ABS(RGTVAL-MISVAL))) THEN NWRGHT = .TRUE. ELSE NWRGHT = .FALSE. BADEND = .TRUE. PRINT *,'ERROR: MACHINE PRECISION TOO LOW TO GET', C 'POSSIBLE EIGENVALUE AT ',MISVAL PRINT *,'REMEDY: EITHER SEARCH FOR MORE EIGENVALUES' PRINT *,'REMEDY: OR TRY A LOWER ERROR TOLERANCE' ENDIF ENDIF ENDIF IF (BADEND) THEN RETVAL = -1 RETURN ELSE IF (NWRGHT) THEN RETVAL = 2 RETURN ENDIF * SORT THE EIGENVALUES AND RELATED DATA CALL CPYVEC(OEIGNM,SRTTHT,OTHETA) CALL BSORT(OEIGNM,SRTTHT) * FRWRKV(1) CONTAINS THE SORTED DISTANCES OF EIGENVALUE FROM OSIGMA * FIWRKV(1) THE INDICES OF THE SORTED DISTANCES DO 10 I = 1, OEIGNM FRWRKV(I,1) = ABS(SRTTHT(I)-OSIGMA) FIWRKV(I,1) = I 10 CONTINUE CALL BSORT2(OEIGNM,FRWRKV(1,1),FIWRKV(1,1)) DO 20 I = 1, OEIGNM THTIDX(FIWRKV(I,1)) = I 20 CONTINUE * GIVE THE DISTANCE OF THE LAST SIGNIFICANT EIGENVALUE FROM OSIGMA EIGBND = FRWRKV(OINDX,1) * DONE WITH FRWRKV(1) AND FIWRKV(1) IF (CBOUND.EQ.1) THEN ONMSGT = GBOUND(INTIDX,SIGLST,INTLST,BLEFT,BRIGHT,0) ENDIF * THE MAIN LOOP EXECUTED UNTIL WE REACH A DECISION 100 CONTINUE IF ((OEIGNM.GE.ONMSGT).OR.(CBOUND.EQ.1)) THEN * CHECK GAPS CHKSTS = CHKGAP(INTIDX,SIGLST,INTLST, C OEIGNM,SRTTHT,FIWRKV(1,1),THTIDX,FRWRKV(1,1),WORKV1, C FIWRKV(1,2),0.001D0,ONMSGT,N,PSTERR,RGTVAL,OSIGMA,NMSGT, C CBOUND,BLEFT,BRIGHT,PROB) IF (DEBUG.GT.0) THEN PRINT *,'CHKSTS = ',CHKSTS ENDIF IF (CHKSTS.EQ.-1) THEN NWRGHT = .TRUE. FINCHK = .TRUE. ELSE IF (CHKSTS.EQ.-3) THEN CALL BOPER(N,WORKV1,WORKV1,RGTVAL,PROB,6,FACTYP, C FALEAD,FA,FARP,FARL,FIWRKV,FRWRKV,INTLST, C SIGLST,INTIDX,DEBUG,NROLL,WRKPTR, C FASIZE,FAADDR,TMEM,KFORM,KAUX,KRP,KCP, C MFORM,MAUX,MRP,MCP,BFACT,MAXDLY,INSIZE,INPTR,INADDR) ELSE IF (CHKSTS.EQ.-2) THEN BADEND = .TRUE. ELSE IF (CHKSTS.EQ.0) THEN OKAY = .TRUE. ELSE IF (CHKSTS.EQ.1) THEN FINCHK = .TRUE. ENDIF ELSE FINCHK = .TRUE. ENDIF IF (OKAY.OR.FINCHK.OR.BADEND) GOTO 110 GOTO 100 110 CONTINUE NWLEFT = .FALSE. IF (BADEND) THEN RETVAL = -1 ELSE IF (OKAY) THEN RETVAL = 0 ELSE IF (NWRGHT) THEN RETVAL = 2 ELSE IF (FINCHK) THEN RETVAL = 1 ELSE PRINT *,'ERROR: BUG IN CHKFIN' PRINT *,'REMEDY: CONTACT TESTBED ADMINISTRATOR' RETVAL = -1 ENDIF RETURN END * FINDS IF ANY EIGENVALUES WERE MISSED INTEGER FUNCTION SRCHLW(OEIGNM,OTHETA,R1LEN,R1THET,R1BJ, C R2LEN,R2THET,R2BJ,ONMSGT,OSIGMA,WORKV,MISVAL,MISBJ,ATOL) * NUMBER OF GOOD EIGS INTEGER OEIGNM * GOOD THETA'S DOUBLE PRECISION OTHETA(*) * # OF OTHER THETA'S INTEGER R1LEN * OTHER THETA'S DOUBLE PRECISION R1THET(*) * ERROR BOUNDS FOR R1'S DOUBLE PRECISION R1BJ(*) * # OF OTHER THETA'S INTEGER R2LEN * OTHER THETA'S DOUBLE PRECISION R2THET(*) * ERROR BOUNDS FOR R2'S DOUBLE PRECISION R2BJ(*) * THE ORIGINAL NUMBER OF EIGENVALUES SOUGHT INTEGER ONMSGT * THE ORIGINAL SIGMA TO SEARCH AROUND DOUBLE PRECISION OSIGMA * A WORK VECTOR DOUBLE PRECISION WORKV(*) * ONE OF THE MISSING VALUES DOUBLE PRECISION MISVAL * THE BJ OF THE MISSING VALUE DOUBLE PRECISION MISBJ * THE TOLERANCE NEEDED FOR EIGENVALUE ACCEPTANCE DOUBLE PRECISION ATOL * INTERNAL VARIABLES * COUNT VARIABLES INTEGER I, J * THE NUMBER OF EIGENVALUES GREATER THAN THE MISSED VALUE INTEGER LEVEL * THE TOTAL NUMBER OF VALUES LESS THAN SIGMA INTEGER TOTAL * HAVE WE FOUND A MISSING VAL YET? LOGICAL FIRST * THE MINIMUM DISTANCE FROM OSIGMA FOR A MISSED EIGENVALUE DOUBLE PRECISION MNDIST * THE DISTANCE FROM OSIGMA FOR EIGENVALUE DOUBLE PRECISION DIST DO 10 I = 1, OEIGNM WORKV(I) = ABS(OSIGMA-OTHETA(I)) 10 CONTINUE CALL BSORT(OEIGNM,WORKV) TOTAL = 0 LEVEL = 0 FIRST = .TRUE. DO 20 I = 1, R1LEN IF ((R1BJ(I).LT.0.0D0).AND.(R1BJ(I).GT.(-100.0D0*ATOL))) THEN DO 30 J = ONMSGT, 1, -1 DIST = ABS(OSIGMA-R1THET(I)) IF (DIST.LT.WORKV(J)) THEN LEVEL = MAX0((ONMSGT-J)+1,LEVEL) IF (J.EQ.ONMSGT) THEN TOTAL = TOTAL + 1 IF (FIRST) THEN FIRST = .FALSE. MISVAL = R1THET(I) MISBJ = R1BJ(I) MNDIST = DIST ELSE IF (DIST.LT.MNDIST) THEN MISVAL = R1THET(I) MISBJ = R1BJ(I) MNDIST = DIST ENDIF ENDIF ENDIF ELSE GOTO 40 ENDIF 30 CONTINUE 40 CONTINUE ENDIF 20 CONTINUE DO 50 I = 1, R2LEN IF ((R2BJ(I).LT.0.0D0).AND.(R2BJ(I).GT.(-100.0D0*ATOL))) THEN DO 60 J = ONMSGT, 1, -1 DIST = ABS(OSIGMA-R2THET(I)) IF (DIST.LT.WORKV(J)) THEN LEVEL = MAX0((ONMSGT-J)+1,LEVEL) IF (J.EQ.ONMSGT) THEN TOTAL = TOTAL + 1 IF (FIRST) THEN FIRST = .FALSE. MISVAL = R2THET(I) MISBJ = R2BJ(I) MNDIST = DIST ELSE IF (DIST.LT.MNDIST) THEN MISVAL = R2THET(I) MISBJ = R2BJ(I) MNDIST = DIST ENDIF ENDIF ENDIF ELSE GOTO 70 ENDIF 60 CONTINUE 70 CONTINUE ENDIF 50 CONTINUE SRCHLW = MIN(TOTAL,LEVEL) RETURN END * CHECKS GAPS BETWEEN INERTIA CHECKS INTEGER FUNCTION CHKGAP(INTIDX,SIGLST,INTLST, C NUMEIG,SRTTHT,THTACT,THTIDX,THTCLS,GAPNUM,GAPNM2,ATOL, C ONMSGT,N,PSTERR,SIGMA,OSIGMA,NMSGT,CBOUND,BLEFT,BRIGHT,PROB) * THE NUMBER OF SHIFTS WITH INERTIA CHECKS TAKEN INTEGER INTIDX * THE VALUES OF THE SHIFTS DOUBLE PRECISION SIGLST(*) * THE INERTIAS AT THE SHIFTS INTEGER INTLST(*) * THE NUMBER OF EIGENVALUES FOUND SO FAR INTEGER NUMEIG * THE SORTED EIGENVALUES DOUBLE PRECISION SRTTHT(*) * THE STATUS OF THE SORTED EIGENVALUES INTEGER THTACT(*) * THE RANK OF THE SORTED EIGENVALUES INTEGER THTIDX(*) * ARE THESE EIGENVALUES VERY CLOSE? LOGICAL THTCLS(*) * THE NUMBER OF EIGENVALUES IN EACH GAP INTEGER GAPNUM(*) * THE NUMBER OF USED EIGENVALUES IN EACH GAP INTEGER GAPNM2(*) * THE ERROR TOLERANCE ALLOWED DOUBLE PRECISION ATOL * THE NUMBER OF EIGENVALUES REQUESTED BY THE USER INTEGER ONMSGT * THE NUMBER OF EQUATIONS INTEGER N * ARE WE LOOKING FOR UNCHECKED GAPS? LOGICAL PSTERR * THE SHIFT TO WORK ON DOUBLE PRECISION SIGMA * THE ORIGINAL SIGMA DOUBLE PRECISION OSIGMA * THE NUMBER OF EIGENVALUES THAT LANZ IS SEARCHING FOR INTEGER NMSGT * BOUNDARIES? INTEGER CBOUND * THE LEFT AND RIGHT BOUNDARIES DOUBLE PRECISION BLEFT, BRIGHT * VIBRATION (0) OR BUCKLING (1) INTEGER PROB * INTERNAL EIGENVALUES * BOUNDARIES FOR MISSED VALUE DOUBLE PRECISION LEFT, RIGHT * DIRECTION TO SEARCH IN INTEGER DIR * STARTING VALUE TO SEARCH FROM DOUBLE PRECISION START * COUNT VARIABLES INTEGER I,J * ARE THERE UNACCOUNTED VALUES IN THE TOP AND BOTTOM GAPS? LOGICAL TZERO, BZERO * THE INDICES OF THE HI AND LOW USED EIGENVALUES INTEGER HINUM, LONUM * USED FOR DETERMINING BOUNDARY EIGENVALUES INTEGER THINUM, TLONUM * THE NUMBER OF GOOD EIGENVALUES ACCOUNTED FOR INTEGER NUMACT * IS THERE A GAP CONTAINING EIGENVALUES WE NEED LOGICAL SIGGAP * IS THERE A GAP CONTAINING TOO MANY EIGENVALUES LOGICAL BADGAP * TEMPORARY VERSION OF SIGGAP LOGICAL TMPGAP * THE NUMBER OF MISSING EIGENVALUES INTEGER SIGNUM * TEMPORARY VERSION OF SIGNUM INTEGER TMPNUM * THE MIDPOINT IN A GAP DOUBLE PRECISION MIDPNT * THE DISTANCE A GAP IS FROM OSIGMA DOUBLE PRECISION DIST * TEMPORARY VERSION OF DIST DOUBLE PRECISION TDIST * LOGICAL FUNCTIONS LOGICAL ECLOSE, GSHIFT * THE NUMBER OF EIGENVALUES EXPECTED BETWEEN TWO SHIFTS INTEGER NUMNGP IF ((NUMEIG.LT.ONMSGT).AND.(CBOUND.EQ.0)) THEN PRINT *,'ERROR: NOT ENOUGH EIGENVALUES TO CHECK GAPS' PRINT *,'REMEDY: CONTACT TESTBED ADMINISTRATOR' STOP ENDIF * SORT THE SHIFTS, INITIALIZE GAPNM, AND INITIALIZE THTACT CALL BSORT2(INTIDX,SIGLST,INTLST) DO 5 I = 1, INTIDX+1 GAPNUM(I) = 0 GAPNM2(I) = 0 5 CONTINUE DO 7 I = 1, NUMEIG THTACT(I) = -1 7 CONTINUE DO 9 I = 1, NUMEIG-1 THTCLS(I) = ECLOSE(ATOL,SRTTHT(I),SRTTHT(I+1)) 9 CONTINUE * CHECK OFF EIGENVALUES IN GAPS TLONUM = 0 LONUM = 0 DO 10 I = 1, NUMEIG IF ((LONUM.EQ.0).AND.(THTIDX(I).LE.ONMSGT)) THEN LONUM = I ENDIF DO 20 J = 2, INTIDX IF ((SRTTHT(I).GT.SIGLST(J-1)).AND. C (SRTTHT(I).LT.SIGLST(J))) THEN GAPNUM(J) = GAPNUM(J) + 1 IF (THTIDX(I).LE.ONMSGT) THEN GAPNM2(J) = GAPNM2(J) + 1 ENDIF THTACT(I) = 1 TLONUM = -1 GOTO 30 ENDIF 20 CONTINUE * THIS COULD BE A BOUNDARY EIGENVALUE IF (THTIDX(I).LE.ONMSGT) THEN IF (TLONUM.EQ.0) THEN THTACT(I) = 2 TLONUM = I ELSE IF ((TLONUM.GT.0).AND.THTCLS(I-1).AND. C (THTACT(I-1).EQ.2)) THEN THTACT(I) = 2 ELSE THTACT(I) = 0 ENDIF ELSE THTACT(I) = 0 ENDIF IF (INTIDX.EQ.0) THEN GAPNUM(1) = GAPNUM(1) + 1 IF (THTIDX(I).LE.ONMSGT) THEN GAPNM2(1) = GAPNM2(1) + 1 ENDIF ELSE IF (SRTTHT(I).LE.SIGLST(1)) THEN GAPNUM(1) = GAPNUM(1) + 1 THTACT(I) = THTACT(I) + 8 ELSE IF (SRTTHT(I).GT.SIGLST(INTIDX)) THEN GAPNUM(INTIDX+1) = GAPNUM(INTIDX+1) + 1 THTACT(I) = THTACT(I) + 16 ENDIF 30 CONTINUE 10 CONTINUE THINUM = 0 HINUM = 0 * TRAVERSE IN THE OTHER DIRECTION TO CLEAN UP THE DO 40 I = NUMEIG, 1, -1 IF ((HINUM.EQ.0).AND.(THTIDX(I).LE.ONMSGT)) THEN HINUM = I ENDIF IF (THTACT(I)/16.GE.1) THEN IF ((GAPNUM(INTIDX+2).EQ.(N-INTLST(INTIDX))).AND. C (PROB.EQ.0)) THEN THTACT(I) = 1 ELSE THTACT(I) = THTACT(I) - 16 ENDIF IF (THTIDX(I).LE.ONMSGT) THEN GAPNM2(INTIDX+1) = GAPNM2(INTIDX+1) + 1 ENDIF ELSE IF (THTACT(I)/8.GE.1) THEN IF ((GAPNUM(1).EQ.INTLST(1)).AND.(PROB.EQ.0)) THEN THTACT(I) = 1 ELSE THTACT(I) = THTACT(I) - 8 ENDIF IF (THTIDX(I).LE.ONMSGT) THEN GAPNM2(1) = GAPNM2(1) + 1 ENDIF ENDIF IF (THTIDX(I).LE.ONMSGT) THEN IF (THINUM.EQ.0) THEN IF (THTACT(I).EQ.1) THEN THINUM = -1 ELSE THINUM = I THTACT(I) = 3 ENDIF ELSE IF ((THINUM.GT.0).AND.THTCLS(I).AND. C (THTACT(I+1).EQ.3)) THEN THTACT(I) = 3 ENDIF ENDIF 40 CONTINUE IF (TLONUM.GT.0) THEN IF (THTACT(TLONUM).NE.2) THEN TLONUM = -1 ENDIF ENDIF TZERO = .FALSE. BZERO = .FALSE. DO 45 I = 1, NUMEIG IF ((THTACT(I).EQ.2).AND.(TLONUM.LT.1).AND.(PROB.EQ.0)) THEN THTACT(I) = 0 ENDIF IF ((THTACT(I).EQ.0).AND.(THTIDX(I).LE.ONMSGT)) THEN IF (INTIDX.EQ.0) THEN TZERO = .TRUE. BZERO = .TRUE. ELSE IF (SRTTHT(I).LT.SIGLST(1)) THEN BZERO = .TRUE. ELSE IF (SRTTHT(I).GT.SIGLST(INTIDX)) THEN TZERO = .TRUE. ENDIF ENDIF ENDIF 45 CONTINUE * MAKE SURE THAT NO GAP HAS TOO MANY EIGENVALUES * AND THAT NO GAP IS MISSING DESIRED EIGENVALUES BADGAP = .FALSE. SIGGAP = .FALSE. NUMACT = ONMSGT - GAPNM2(1) IF ((INTIDX.GT.0).AND.(GAPNUM(1).GT.INTLST(1)).AND.(PROB.EQ.0)) C THEN BADGAP = .TRUE. PRINT *,'ERROR: TOO MANY EIGENVALUES BETWEEN -INFINITY AND ', C SIGLST(1) PRINT *,'REMEDY: EXAMINE OUTPUT AND ', C 'CONTACT TESTBED ADMINISTRATOR' ENDIF IF ((INTIDX.GT.0).AND.(GAPNUM(INTIDX+1).GT.N-INTLST(INTIDX)).AND. C (PROB.EQ.0)) THEN BADGAP = .TRUE. PRINT *,'ERROR: TOO MANY EIGENVALUES BETWEEN ',SIGLST(INTIDX), C ' AND +INFINITY' PRINT *,'REMEDY: EXAMINE OUTPUT AND ', C 'CONTACT TESTBED ADMINISTRATOR' ENDIF DO 50 I = 2, INTIDX IF (PROB.EQ.0) THEN NUMNGP = INTLST(I) - INTLST(I-1) ELSE IF ((SIGLST(I).GT.0.0D0).AND.(SIGLST(I-1).GE.0.0D0)) THEN NUMNGP = INTLST(I) - INTLST(I-1) ELSE IF ((SIGLST(I).GT.0.0D0).AND.(SIGLST(I-1).LT.0.0D0)) C THEN NUMNGP = INTLST(I) + INTLST(I-1) ELSE NUMNGP = INTLST(I-1) - INTLST(I) ENDIF ENDIF IF (GAPNUM(I).GT.NUMNGP) THEN BADGAP = .TRUE. PRINT *,'ERROR: TOO MANY EIGENVALUES BETWEEN ', C SIGLST(I-1),' AND ',SIGLST(I) PRINT *,'REMEDY: EXAMINE OUTPUT AND ', C 'CONTACT TESTBED ADMINISTRATOR' ELSE IF (GAPNUM(I).LT.NUMNGP) THEN MIDPNT = (SIGLST(I)+SIGLST(I-1))/2.0D0 TMPNUM = NUMNGP - GAPNUM(I) IF ((CBOUND.EQ.1).AND.((SIGLST(I).GT.BRIGHT).OR. C (SIGLST(I-1).LT.BLEFT))) THEN TMPGAP = .FALSE. ELSE IF (CBOUND.EQ.1) THEN TMPGAP = .TRUE. ELSE IF ((NUMACT-GAPNM2(I).GT.0).AND.(NUMACT.LT.ONMSGT)) C THEN TMPGAP = .TRUE. ELSE IF ((NUMACT.LT.ONMSGT).AND.(OSIGMA.GE.MIDPNT)) THEN TMPGAP = .TRUE. ELSE IF ((NUMACT-GAPNM2(I).GT.0).AND. C (OSIGMA.LE.MIDPNT)) THEN TMPGAP = .TRUE. ELSE TMPGAP = .FALSE. ENDIF IF (TMPGAP) THEN IF ((OSIGMA.GT.SIGLST(I-1)).AND. C (OSIGMA.LT.SIGLST(I))) THEN TDIST = 0.0D0 ELSE TDIST = MIN(ABS(OSIGMA-SIGLST(I-1)), C ABS(OSIGMA-SIGLST(I))) ENDIF IF (SIGGAP) THEN IF (TDIST.LT.DIST) THEN LEFT = SIGLST(I-1) RIGHT = SIGLST(I) DIST = TDIST SIGNUM = TMPNUM ENDIF ELSE SIGGAP = .TRUE. DIST = TDIST LEFT = SIGLST(I-1) RIGHT = SIGLST(I) SIGNUM = TMPNUM ENDIF ENDIF ENDIF NUMACT = NUMACT - GAPNM2(I) 50 CONTINUE IF (BADGAP) THEN CHKGAP = -2 RETURN ELSE IF (SIGGAP) THEN CHKGAP = -1 NMSGT = MIN(NUMEIG + SIGNUM,N) START = (RIGHT+LEFT)/2.0D0 IF (ABS(OSIGMA-LEFT).LT.(ABS(OSIGMA-RIGHT))) THEN DIR = -1 ELSE DIR = 1 ENDIF IF (GSHIFT(SIGMA,LEFT,RIGHT,-1,START,ATOL,NUMEIG, C SRTTHT,THTIDX,ONMSGT,.FALSE.)) THEN CHKGAP = -1 RETURN ELSE PRINT *,'ERROR: THERE IS A MISSING EIGENVALUE, BUT THE', C ' EIGENVALUES WERE TOO CLUSTERED TO CONTINUE' PRINT *,'REMEDY: TRY A PUTTING A SHIFT IN THE BAD REGION', C ' YOURSELF' CHKGAP = -2 RETURN ENDIF ENDIF * CHECK FOR VALUES THAT MAY NOT BE INERTIA CHECKED IF (PSTERR) THEN IF (INTIDX.EQ.0) THEN IF (HINUM.LE.2) THEN PRINT *,'ERROR: NO PLACE FOR INERTIA CHECK SHIFT' PRINT *,'REMEDY: NEED TO FIND MORE EIGENVALUES' CHKGAP = -2 RETURN ELSE START = (SRTTHT(HINUM)+SRTTHT(HINUM-1))/2 LEFT = SRTTHT(LONUM) RIGHT = SRTTHT(HINUM) IF (GSHIFT(SIGMA,LEFT,RIGHT,-1,START,ATOL,NUMEIG, C SRTTHT,THTIDX,ONMSGT,.TRUE.)) THEN CHKGAP = -3 RETURN ELSE PRINT *,'ERROR: THE EIGENVALUES WERE TOO', C ' CLUSTERED TO DO AN INERTIA CHECK' PRINT *,'REMEDY: EITHER FIND MORE EIGENVALUES OR', C ' RESTART AND CHOOSE A NEW SHIFT YOURSELF' CHKGAP = -2 RETURN ENDIF ENDIF ELSE IF (TZERO) THEN LEFT = SIGLST(INTIDX) RIGHT = SRTTHT(HINUM) START = (SRTTHT(HINUM)+SRTTHT(HINUM-1))/2 IF (GSHIFT(SIGMA,LEFT,RIGHT,-1,START,ATOL,NUMEIG, C SRTTHT,THTIDX,ONMSGT,.TRUE.)) THEN CHKGAP = -3 RETURN ELSE PRINT *,'ERROR: THE EIGENVALUES WERE TOO', C ' CLUSTERED TO DO AN INERTIA CHECK' PRINT *,'REMEDY: EITHER FIND MORE EIGENVALUES OR', C ' RESTART AND CHOOSE A NEW SHIFT YOURSELF' CHKGAP = -2 RETURN ENDIF ELSE IF (BZERO) THEN LEFT = SRTTHT(LONUM) RIGHT = SIGLST(1) START = (SRTTHT(LONUM)+SRTTHT(LONUM+1))/2 IF (GSHIFT(SIGMA,LEFT,RIGHT,1,START,ATOL,NUMEIG, C SRTTHT,THTIDX,ONMSGT,.TRUE.)) THEN CHKGAP = -3 RETURN ELSE PRINT *,'ERROR: THE EIGENVALUES WERE TOO', C ' CLUSTERED TO DO AN INERTIA CHECK' PRINT *,'REMEDY: EITHER FIND MORE EIGENVALUES OR', C ' RESTART AND CHOOSE A NEW SHIFT YOURSELF' CHKGAP = -2 RETURN ENDIF ELSE DO 60 I = 2, INTIDX IF (PROB .EQ. 0) THEN NUMNGP = INTLST(I) - INTLST(I-1) ELSE IF ((SIGLST(I).GT.0.0D0).AND.(SIGLST(I-1).GE.0.0D0)) C THEN NUMNGP = INTLST(I) - INTLST(I-1) ELSE IF ((SIGLST(I).GT.0.0D0).AND. C (SIGLST(I-1).LT.0.0D0)) THEN NUMNGP = INTLST(I) + INTLST(I-1) ELSE NUMNGP = INTLST(I-1) - INTLST(I) ENDIF ENDIF IF ((GAPNUM(I).LT.NUMNGP).AND. C (GAPNM2(I).GT.0)) THEN IF (GAPNM2(I).EQ.1) THEN IF ((SRTTHT(HINUM).GT.SIGLST(I-1)).AND. C(SRTTHT(HINUM).LT.SIGLST(I))) THEN GOTO 60 ENDIF IF ((SRTTHT(LONUM).GT.SIGLST(I-1)).AND. C(SRTTHT(LONUM).LT.SIGLST(I))) THEN GOTO 60 ENDIF ENDIF IF ((SRTTHT(HINUM).GT.SIGLST(I-1)).AND. C(SRTTHT(HINUM).LE.SIGLST(I))) THEN IF (HINUM.EQ.1) THEN START = (SRTTHT(HINUM)+SIGLST(I-1))/2.0D0 ELSE START = MAX(SIGLST(I-1),SRTTHT(HINUM-1)) START = (SRTTHT(HINUM)+START)/2.0D0 ENDIF RIGHT = SRTTHT(HINUM) LEFT = SIGLST(I-1) DIR = -1 ELSE IF ((SRTTHT(LONUM).GE.SIGLST(I-1)).AND. C (SRTTHT(LONUM).LT.SIGLST(I))) THEN IF (LONUM.EQ.NUMEIG) THEN START = (SRTTHT(LONUM)+SIGLST(I))/2.0D0 ELSE START = MIN(SIGLST(I),SRTTHT(LONUM+1)) START = (SRTTHT(LONUM)+START)/2.0D0 ENDIF RIGHT = SIGLST(I) LEFT = SRTTHT(LONUM) DIR = 1 ELSE RIGHT = SIGLST(I) LEFT = SIGLST(I-1) START = (RIGHT+LEFT)/2.0D0 IF (ABS(OSIGMA-LEFT).LT.(ABS(OSIGMA-RIGHT))) THEN DIR = -1 ELSE DIR = 1 ENDIF ENDIF IF (GSHIFT(SIGMA,LEFT,RIGHT,DIR,START,ATOL,NUMEIG, C SRTTHT,THTIDX,ONMSGT,.TRUE.)) THEN CHKGAP = -3 RETURN ELSE PRINT *,'ERROR: THE EIGENVALUES WERE TOO', C ' CLUSTERED TO DO AN INERTIA CHECK' PRINT *,'REMEDY: EITHER FIND MORE EIGENVALUES OR', C ' RESTART AND CHOOSE A NEW SHIFT YOURSELF' CHKGAP = -2 RETURN ENDIF ENDIF 60 CONTINUE ENDIF ELSE CHKGAP = 1 ENDIF CHKGAP = 0 RETURN END LOGICAL FUNCTION ECLOSE(ATOL,EIG1,EIG2) * THE ACCURACY OF THE EIGENVALUES DOUBLE PRECISION ATOL * THE TWO EIGENVALUES DOUBLE PRECISION EIG1, EIG2 * INTERNAL VARIABLES * THE ERROR IN EACH EIGENVALUE DOUBLE PRECISION ERR1, ERR2 ERR1 = ATOL*EIG1 ERR2 = ATOL*EIG2 IF (ERR1+ERR2.GT.ABS(EIG2-EIG1)) THEN ECLOSE = .TRUE. ELSE ECLOSE = .FALSE. ENDIF RETURN END LOGICAL FUNCTION GSHIFT(SIGMA,LEFT,RIGHT,DIR,START,ATOL, C NUMEIG,SRTTHT,THTIDX,ONMSGT,GUESS) * THE NEW SHIFT DOUBLE PRECISION SIGMA * THE LEFT AND RIGHT BOUNDARIES DOUBLE PRECISION LEFT, RIGHT * THE DIRECTIONS PREFERRED INTEGER DIR * STARTING PLACE TO LOOK FOR THE SHIFT DOUBLE PRECISION START * THE ERROR TOLERANCE DOUBLE PRECISION ATOL * THE NUMBER OF EIGENVALUES FOUND INTEGER NUMEIG * THE EIGENVALUES IN SORTED ORDER DOUBLE PRECISION SRTTHT(*) * THE INDICES OF THE EIGENVALUES INTEGER THTIDX(*) * THE NUMBER OF EIGENVALUES REQUESTED BY THE USER INTEGER ONMSGT * DO WE WANT TO PUT SIGMA NEAR A BOUNDARY LOGICAL GUESS * INTERNAL VARIABLES * COUNT VARIABLES INTEGER I * THE INDEX OF THE EIGENVALUES JUST ABOVE START INTEGER MINDEX * THE VALUE OF THE MINDEX'TH EIGENVALUES DOUBLE PRECISION MVAL * THE CURRENT EIGENVALUE BEING LOOKED AT INTEGER CINDEX * LOGICAL FUNCTIONS LOGICAL SOKAY IF (NUMEIG.EQ.0) THEN IF (SOKAY(SIGMA,LEFT,SRTTHT(CINDEX), C DIR,LEFT,RIGHT,ATOL,GUESS)) THEN GSHIFT = .TRUE. ELSE GSHIFT = .FALSE. ENDIF RETURN ENDIF GSHIFT = .FALSE. * GET BOUND MINDEX = 0 DO 10 I = 1, NUMEIG IF (SRTTHT(I).GT.START) THEN IF (MINDEX.EQ.0) THEN MINDEX = I MVAL = SRTTHT(I) ELSE IF (SRTTHT(I).LT.MVAL) THEN MINDEX = I MVAL = SRTTHT(I) ENDIF ENDIF 10 CONTINUE IF (MINDEX.EQ.0) THEN MINDEX = NUMEIG + 1 ENDIF * DECIDE WHICH TO DO FIRST IF (DIR.EQ.-1) GOTO 200 * DO RIGHT 100 CONTINUE CINDEX = MINDEX 110 CONTINUE IF (CINDEX.LT.1) GOTO 190 IF (CINDEX.GT.NUMEIG+1) GOTO 190 IF (THTIDX(CINDEX).GT.ONMSGT) GOTO 190 IF (CINDEX.EQ.1) THEN IF (SOKAY(SIGMA,LEFT,SRTTHT(CINDEX), C DIR,LEFT,RIGHT,ATOL,GUESS)) THEN GSHIFT = .TRUE. RETURN ENDIF ELSE IF (CINDEX.EQ.NUMEIG+1) THEN IF (SOKAY(SIGMA,SRTTHT(CINDEX-1),RIGHT, C DIR,LEFT,RIGHT,ATOL,GUESS)) THEN GSHIFT = .TRUE. RETURN ENDIF ELSE IF (SOKAY(SIGMA,SRTTHT(CINDEX-1),SRTTHT(CINDEX), C DIR,LEFT,RIGHT,ATOL,GUESS)) THEN GSHIFT = .TRUE. RETURN ENDIF ENDIF CINDEX = CINDEX - 1 GOTO 110 * QUIT IF LEFT FIRST ELSE DO LEFT 190 CONTINUE IF (DIR.EQ.-1) RETURN * DO LEFT 200 CONTINUE CINDEX = MINDEX 210 CONTINUE IF (CINDEX.LT.1) GOTO 290 IF (CINDEX.GT.NUMEIG+1) GOTO 290 IF (THTIDX(CINDEX).GT.ONMSGT) GOTO 290 IF (CINDEX.EQ.1) THEN IF (SOKAY(SIGMA,LEFT,SRTTHT(CINDEX), C DIR,LEFT,RIGHT,ATOL,GUESS)) THEN GSHIFT = .TRUE. RETURN ENDIF ELSE IF (CINDEX.EQ.NUMEIG+1) THEN IF (SOKAY(SIGMA,SRTTHT(CINDEX-1),RIGHT, C DIR,LEFT,RIGHT,ATOL,GUESS)) THEN GSHIFT = .TRUE. RETURN ENDIF ELSE IF (SOKAY(SIGMA,SRTTHT(CINDEX-1),SRTTHT(CINDEX), C DIR,LEFT,RIGHT,ATOL,GUESS)) THEN GSHIFT = .TRUE. RETURN ENDIF ENDIF CINDEX = CINDEX + 1 GOTO 210 * QUIT IF RIGHT FIRST ELSE DO RIGHT 290 CONTINUE IF (DIR.EQ.-1) GOTO 100 RETURN END LOGICAL FUNCTION SOKAY(SIGMA,LEFT,RIGHT,DIR,BLEFT,BRIGHT,ATOL, C GUESS) * THE NEW SHIFT DOUBLE PRECISION SIGMA * THE LEFT AND RIGHT EIGENVALUES DOUBLE PRECISION LEFT, RIGHT * THE PREFERRED DIRECTION INTEGER DIR * THE LEFT AND RIGHT BOUNDARIES DOUBLE PRECISION BLEFT, BRIGHT * THE ERROR TOLERANCE DOUBLE PRECISION ATOL * DO WE WANT TO PUT SIGMA NEAR A BOUNDARY LOGICAL GUESS * INTERNAL VARIABLES * THE BOUNDARIES ON SIGMA DOUBLE PRECISION TLEFT, TRIGHT * TOLERANCE ON THE BOUNDS DOUBLE PRECISION BTOL BTOL = 0.0001D0 SOKAY = .FALSE. TLEFT = MAX((LEFT + BTOL*ABS(LEFT)),(BLEFT + BTOL*ABS(BLEFT))) TRIGHT = MIN((RIGHT - BTOL*ABS(RIGHT)), C (BRIGHT - BTOL*ABS(BRIGHT))) IF (TLEFT.LT.TRIGHT) THEN IF (GUESS) THEN IF (DIR.EQ.-1) THEN SIGMA = TRIGHT SOKAY = .TRUE. ELSE SIGMA = TLEFT SOKAY = .TRUE. ENDIF ELSE SIGMA = (TLEFT+TRIGHT)/2.0D0 SOKAY = .TRUE. ENDIF ENDIF RETURN END C$FORTRAN DBLAS *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: DBLAS.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: PERFORM VECTOR-VECTOR OPERATIONS * *********************************************************************** DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) C C TAKES THE SUM OF THE ABSOLUTE VALUES. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DTEMP INTEGER I,INCX,M,MP1,N,NINCX C DASUM = 0.0D0 DTEMP = 0.0D0 IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX DTEMP = DTEMP + DABS(DX(I)) 10 CONTINUE DASUM = DTEMP RETURN C C CODE FOR INCREMENT EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,6) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DTEMP + DABS(DX(I)) 30 CONTINUE IF( N .LT. 6 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,6 DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I + 1)) + DABS(DX(I + 2)) * + DABS(DX(I + 3)) + DABS(DX(I + 4)) + DABS(DX(I + 5)) 50 CONTINUE 60 DASUM = DTEMP RETURN END SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DA INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF (DA .EQ. 0.0D0) RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C 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 DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I + 1) = DY(I + 1) + DA*DX(I + 1) DY(I + 2) = DY(I + 2) + DA*DX(I + 2) DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 50 CONTINUE RETURN END SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) C C COPIES A VECTOR, X, TO A VECTOR, Y. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1) INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C 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 DY(IY) = DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 DY(I) = DX(I) DY(I + 1) = DX(I + 1) DY(I + 2) = DX(I + 2) DY(I + 3) = DX(I + 3) DY(I + 4) = DX(I + 4) DY(I + 5) = DX(I + 5) DY(I + 6) = DX(I + 6) 50 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) C C FORMS THE DOT PRODUCT OF TWO VECTORS. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C DDOT = 0.0D0 DTEMP = 0.0D0 IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DTEMP + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE DDOT = DTEMP RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DTEMP + DX(I)*DY(I) 30 CONTINUE IF( N .LT. 5 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,5 DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 50 CONTINUE 60 DDOT = DTEMP RETURN END DOUBLE PRECISION FUNCTION DMACH(JOB) INTEGER JOB C C SMACH COMPUTES MACHINE PARAMETERS OF FLOATING POINT C ARITHMETIC FOR USE IN TESTING ONLY. NOT REQUIRED BY C LINPACK PROPER. C C IF TROUBLE WITH AUTOMATIC COMPUTATION OF THESE QUANTITIES, C THEY CAN BE SET BY DIRECT ASSIGNMENT STATEMENTS. C ASSUME THE COMPUTER HAS C C B = BASE OF ARITHMETIC C T = NUMBER OF BASE B DIGITS C L = SMALLEST POSSIBLE EXPONENT C U = LARGEST POSSIBLE EXPONENT C C THEN C C EPS = B**(1-T) C TINY = 100.0*B**(-L+T) C HUGE = 0.01*B**(U-T) C C DMACH SAME AS SMACH EXCEPT T, L, U APPLY TO C DOUBLE PRECISION. C C CMACH SAME AS SMACH EXCEPT IF COMPLEX DIVISION C IS DONE BY C C 1/(X+I*Y) = (X-I*Y)/(X**2+Y**2) C C THEN C C TINY = SQRT(TINY) C HUGE = SQRT(HUGE) C C C JOB IS 1, 2 OR 3 FOR EPSILON, TINY AND HUGE, RESPECTIVELY. C DOUBLE PRECISION EPS,TINY,HUGE,S C EPS = 1.0D0 10 EPS = EPS/2.0D0 S = 1.0D0 + EPS IF (S .GT. 1.0D0) GO TO 10 EPS = 2.0D0*EPS C S = 1.0D0 20 TINY = S S = S/16.0D0 IF (S*1.0 .NE. 0.0D0) GO TO 20 TINY = (TINY/EPS)*100.0 HUGE = 1.0D0/TINY C IF (JOB .EQ. 1) DMACH = EPS IF (JOB .EQ. 2) DMACH = TINY IF (JOB .EQ. 3) DMACH = HUGE RETURN END DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) INTEGER NEXT DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE DATA ZERO, ONE /0.0D0, 1.0D0/ C C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON, 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() DOUBLE PRECISION AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C IF(N .GT. 0) GO TO 10 DNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( DX(I) .EQ. ZERO) GO TO 200 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / DX(I)) / DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / DX(I))**2 XMAX = DABS(DX(I)) GO TO 200 C 115 SUM = SUM + (DX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR DOUBLE PRECISION OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J =I,NN,INCX IF(DABS(DX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + DX(J)**2 DNRM2 = DSQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C DNRM2 = XMAX * DSQRT(SUM) 300 CONTINUE RETURN END SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) C C APPLIES A PLANE ROTATION. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S INTEGER I,INCX,INCY,IX,IY,N C IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL C TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = C*DX(IX) + S*DY(IY) DY(IY) = C*DY(IY) - S*DX(IX) DX(IX) = DTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N DTEMP = C*DX(I) + S*DY(I) DY(I) = C*DY(I) - S*DX(I) DX(I) = DTEMP 30 CONTINUE RETURN END SUBROUTINE DROTG(DA,DB,C,S) C C CONSTRUCT GIVENS PLANE ROTATION. C JACK DONGARRA, LINPACK, 3/11/78. C MODIFIED 9/27/86. C DOUBLE PRECISION DA,DB,C,S,ROE,SCALE,R,Z C ROE = DB IF( DABS(DA) .GT. DABS(DB) ) ROE = DA SCALE = DABS(DA) + DABS(DB) IF( SCALE .NE. 0.0D0 ) GO TO 10 C = 1.0D0 S = 0.0D0 R = 0.0D0 GO TO 20 10 R = SCALE*DSQRT((DA/SCALE)**2 + (DB/SCALE)**2) R = DSIGN(1.0D0,ROE)*R C = DA/R S = DB/R 20 Z = S IF( DABS(C) .GT. 0.0D0 .AND. DABS(C) .LE. S ) Z = 1.0D0/C DA = R DB = Z RETURN END SUBROUTINE DSCAL(N,DA,DX,INCX) C C SCALES A VECTOR BY A CONSTANT. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DA,DX(1) INTEGER I,INCX,M,MP1,N,NINCX C IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX DX(I) = DA*DX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I + 1) = DA*DX(I + 1) DX(I + 2) = DA*DX(I + 2) DX(I + 3) = DA*DX(I + 3) DX(I + 4) = DA*DX(I + 4) 50 CONTINUE RETURN END SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) C C INTERCHANGES TWO VECTORS. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL C TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP DTEMP = DX(I + 1) DX(I + 1) = DY(I + 1) DY(I + 1) = DTEMP DTEMP = DX(I + 2) DX(I + 2) = DY(I + 2) DY(I + 2) = DTEMP 50 CONTINUE RETURN END INTEGER FUNCTION IDAMAX(N,DX,INCX) C C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DMAX INTEGER I,INCX,IX,N C IDAMAX = 0 IF( N .LT. 1 ) RETURN IDAMAX = 1 IF(N.EQ.1)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C IX = 1 DMAX = DABS(DX(1)) IX = IX + INCX DO 10 I = 2,N IF(DABS(DX(IX)).LE.DMAX) GO TO 5 IDAMAX = I DMAX = DABS(DX(IX)) 5 IX = IX + INCX 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DMAX = DABS(DX(1)) DO 30 I = 2,N IF(DABS(DX(I)).LE.DMAX) GO TO 30 IDAMAX = I DMAX = DABS(DX(I)) 30 CONTINUE RETURN END C$FORTRAN DPREP *********************************************************************** * LANZ SOFTWARE PACKAGE (TEST PROGRAM) * * FILENAME: DPREP.MSC * * AUTHOR: MARK JONES * * PURPOSE: READS IN DATA FOR THE TEST PROGRAM * *********************************************************************** SUBROUTINE DPREP(IPARAM,RPARAM,IOPAR,LIST,SLIST,ALIST,TMEM, C KAUX,KRP,KCP,MAUX,MRP,MCP,RTOJ) * THESE PARAMETERS ARE BETTER DETAILED IN MAIN.MSC * IPARAM IS A SET OF INTEGER PARAMETERS FOR LANZ INTEGER IPARAM(*) * RPARAM IS A SET OF DOUBLE PRECISION PARAMETERS FOR LANZ DOUBLE PRECISION RPARAM(*) * IOPAR IS THE SET OF I/O RELATED PARAMETERS INTEGER IOPAR(*) * THE LIST OF MEMORY LOCATIONS INTEGER LIST(*) * THE LIST OF MEMORY SIZES INTEGER SLIST(*) * THE LIST OF MEMORY ADDRESSES INTEGER ALIST(*) * THE TOTAL MEMORY ALLOCATED SO FAR INTEGER TMEM * THE K MATRIX DOUBLE PRECISION KAUX(*) * THE ROW POINTERS INTEGER KRP(*) * THE COLUMN INDICES INTEGER KCP(*) * THE M MATRIX DOUBLE PRECISION MAUX(*) * THE ROW POINTERS INTEGER MRP(*) * THE COLUMN INDICES INTEGER MCP(*) * THE ROW TO JOINT VECTOR INTEGER RTOJ(*) * INTERNAL VARIABLES * A LOOP COUNT VARIABLE INTEGER I * LIBRARY AND DATASET SEQUENCE NUMBER (IGNORE IF NOT IN TESTBED) INTEGER LDM, MSDN * ARRAYS OF INPUT PARAMETERS TO BE READ IN INTEGER IV(3,30) DOUBLE PRECISION RV(3,30) * READ IN INPUT PARAMETERS FROM FORT.9 * THE PARAMETERS ARE EXPLAINED IN DRIVER.DOC * PROB READ(9,*) IV(3,7) * MXIT READ(9,*) IV(3,8) * MXLI READ(9,*) IV(3,9) * YSTO READ(9,*) IV(3,10) * CONV READ(9,*) RV(3,12) * DBUG READ(9,*) IV(3,13) * SHIF READ(9,*) RV(3,14) * PLVL READ(9,*) IV(3,15) * CHEC READ(9,*) IV(3,16) * NREQ READ(9,*) IV(3,18) * MCAS READ(9,*) IV(3,19) * FACT READ(9,*) IV(3,22) * NOSH READ(9,*) IV(3,23) * WRIT READ(9,*) IV(3,24) * READ READ(9,*) IV(3,25) * SEAR READ(9,*) IV(3,26) * LEFT READ(9,*) RV(3,27) * RIGH READ(9,*) RV(3,28) * BSTO READ(9,*) RV(3,29) * NUMD READ(9,*) IV(3,30) * SET MAXIMUM NUMBER OF EIGENVALUES THAT CAN BE STORED (YSTO) IPARAM(2) = IV(3,10) * SET THE NUMBER OF EIGENVALUES BEGIN SOUGHT (NREQ) IPARAM(3) = IV(3,18) * SET THE MAXIMUM TOTAL NUMBER OF STEPS TO TAKE (MXIT) IPARAM(4) = IV(3,8) * SET THE LEVEL OF DEBUGGING (DBUG) IPARAM(7) = IV(3,13) * SET THE TYPE OF PROBLEM (PROB) IPARAM(8) = IV(3,7) * SET THE LEVEL OF ERROR CHECKING (PLVL AND CHEC) IF (IV(3,15).EQ.0) THEN * LEVEL 0 = PRINT NOTHING IPARAM(10) = 0 ELSE IF (IV(3,15).EQ.1) THEN * LEVEL 1 = PRINT EIGENVALUES AND INERTIAS IPARAM(10) = 64 + 4 ELSE IF (IV(3,15).EQ.2) THEN * LEVEL 2 = PRINT EIGENVALUES, ESTIMATED ERRORS AND INERTIAS IPARAM(10) = 32 + 4 ELSE IF (IV(3,15).EQ.3) THEN * LEVEL 3 = PRINT EIGENVALUES, ESTIMATED ERRORS, * CALCULATED ERROR AND INERTIAS IPARAM(10) = 16 + 4 ELSE IF (IV(3,15).EQ.4) THEN * LEVEL 4 = PRINT EIGENVALUES, ESTIMATED ERRORS, * CALCULATED ERROR, Y-ORTHOGONALITY AND INERTIAS IPARAM(10) = 16 + 4 + 2 ELSE IF (IV(3,15).EQ.5) THEN * LEVEL 5 = PRINT EIGENVALUES, ESTIMATED ERRORS, * CALCULATED ERROR, Y-ORTHOGONALITY AND INERTIAS * AND THROW IN SOME FREQUENCIES IPARAM(10) = 128 + 16 + 4 + 2 ENDIF * DO AN INERTIA CHECK? IF (IV(3,16).GT.0) THEN IPARAM(9) = 1 ELSE IPARAM(9) = 0 ENDIF * SET THE MAXIMUM TOTAL NUMBER OF STEPS TO TAKE ON ONE LANCZOS * RUN (MXLI) IF (IV(3,9).EQ.0) THEN IF (IPARAM(8).EQ.0) THEN IPARAM(11) = 35 ELSE IPARAM(11) = 45 ENDIF ELSE IPARAM(11) = IV(3,9) ENDIF * SET THE WAY TO READ AND STORE THE MATRICES IPARAM(13) = 0 IPARAM(14) = 0 * SET THE LEVEL OF LOOP UNROLLING (LOOP)(ALWAYS 6 NOW) IPARAM(15) = 6 * SET THE CONSTRAINT CASE NUMBER (IGNORE IF NOT IN TESTBED) IOPAR(2) = IV(3,20) * SET THE SET NUMBER (IGNORE IF NOT IN TESTBED) IOPAR(3) = IV(3,21) * SET THE OUTPUT LIBRARY NUMBER (IGNORE IF NOT IN TESTBED) IOPAR(4) = IV(3,17) * SET THE TYPE OF FACTORIZATION IPARAM(16) = IV(3,22) * SET WHETHER DYNAMIC SHIFTING IS TURNED OFF IPARAM(17) = IV(3,23) * SET TO NO INITIAL GUESS IPARAM(18) = 0 * SET WHETHER WE ARE SEARCHING IN BOUNDARIES OR NOT IPARAM(12) = IV(3,26) * SET THE SHIFT (SHIF) RPARAM(1) = RV(3,14) * SET THE RELATIVE ERROR VALUE (CONV) RPARAM(2) = RV(3,12) * SET THE LEFT BOUNDARY RPARAM(3) = RV(3,27) * SET THE RIGHT BOUNDARY RPARAM(4) = RV(3,28) * SET THE B-K STORAGE FACTOR RPARAM(5) = RV(3,29) * SET THE NUMBER OF DELAYED PIVOTS THAT CAN BE STORED IPARAM(20) = IV(3,30) * SET THE NUMBER OF Y VECTORS TO STORE IF NONE HAS BEEN SET IF (IPARAM(2).LE.0) THEN IPARAM(2) = 1.5 * IPARAM(3) IPARAM(2) = MAX0(IPARAM(2),10) ENDIF IF (IPARAM(3).GT.IPARAM(2)) THEN PRINT *,'WARNING: MAX EIGS SOUGHT TOO LARGE' IPARAM(3) = IPARAM(2) PRINT *,'FIXED: NUMBER RESET TO ',IPARAM(2) ENDIF * READ IN SPARSE MATRICES * NOW LET'S TRY TO READ IN THE DATASETS THAT WE NEED * FIRST GET THE 'K' MATRIX * CALL RDGSP (FROM READIT.MSC) TO READ IN THE K MATRIX CALL RDGSP(LDM,MSDN,KAUX,KRP,KCP,TMEM,LIST(6),LIST(7), C LIST(8),RTOJ,LIST(12),.FALSE.,IPARAM(1),IOPAR(1),IOPAR(5), C IV(3,24),2,IV(3,25),7,SLIST(1),SLIST(2),SLIST(3), C ALIST(6),ALIST(7),ALIST(8),ALIST(12)) * IF WE ARE WORKING WITH A DIAGONAL M MATRIX THEN READ IT IN IF ((IPARAM(8).EQ.0).AND.(IV(3,19).EQ.0)) THEN * GET THE 'DEM' MATRIX * ALLOCATE SPACE FOR THE NONZEROES OF M SLIST(4) = 2*(IPARAM(1)+1) CALL FALLOC(SLIST(4),0,MAUX,TMEM,LIST(9),ALIST(9)) * IF WE ARE READING FROM THE TESTBED IF (IV(3,25).EQ.0) THEN * IF WE ARE READING IN ASCII FORMAT FROM FORT.8 ELSE IF (IV(3,25).EQ.1) THEN * READ IN THE DIAGONAL DO 67 I = 1, IPARAM(1) READ(8,*) MAUX(LIST(9)+I-1) 67 CONTINUE * IF WE ARE DOING AN UNFORMATTED READ FROM FORT.8 ELSE IF (IV(3,25).EQ.2) THEN READ(8) (MAUX(LIST(9)+I-1),I=1,IPARAM(1)) ENDIF * ALLOCATE SPACE FOR THE ROW POINTERS SLIST(5) = 2*(IPARAM(1)+1) CALL FALLOC(SLIST(5),1,MRP,TMEM,LIST(10),ALIST(10)) * ALLOCATE SPACE FOR THE COLUMN NUMBERS SLIST(6) = 2*IPARAM(1) CALL FALLOC(SLIST(6),1,MCP,TMEM,LIST(11),ALIST(11)) * SET ALL THE ROW POINTERS TO ONE DO 65 I = 1, IPARAM(1)+1 MRP(I+LIST(10)-1) = 1 65 CONTINUE * INITIALIZE THE ONLY COLUMN NUMBER TO 1 MCP(LIST(11)) = 1 IF (IV(3,24).EQ.1) THEN DO 66 I = 1, IPARAM(1) WRITE(3,*) MAUX(LIST(9)+I-1) 66 CONTINUE ELSE IF (IV(3,24).EQ.2) THEN WRITE(3) (MAUX(LIST(9)+I-1),I=1,IPARAM(1)) ENDIF * IF WE ARE USING A CONSISTENT MASS MATRIX, A SPARSE MATRIX * THEN READ IT IN ELSE IF (IPARAM(8).EQ.0) THEN * GET THE 'CEM' MATRIX * CALL RDGSP (FROM READIT.MSC) TO READ IN THE M MATRIX CALL RDGSP(LDM,MSDN,MAUX,MRP,MCP,TMEM,LIST(9),LIST(10), C LIST(11),RTOJ,LIST(12),.TRUE.,IPARAM(1),IOPAR(1),IOPAR(5), C IV(3,24),3,IV(3,25),8,SLIST(4),SLIST(5),SLIST(6), C ALIST(9),ALIST(10),ALIST(11),ALIST(12)) * IF WE ARE USING A POSSIBLY INDEFINITE MATRIX IN THE RHS OF THE * EIGENVALUE PROBLEM (SUCH AS IN THE BUCKLING PROBLEM) * THEN READ IT IN (OFTEN THIS MATRIX IS CALLED THE KG MATRIX) ELSE * GET THE 'KG' MATRIX * CALL RDGSP (FROM READIT.MSC) TO READ IN THE MATRIX CALL RDGSP(LDM,MSDN,MAUX,MRP,MCP,TMEM,LIST(9),LIST(10), C LIST(11),RTOJ,LIST(12),.TRUE.,IPARAM(1),IOPAR(1),IOPAR(5), C IV(3,24),3,IV(3,25),8,SLIST(4),SLIST(5),SLIST(6), C ALIST(9),ALIST(10),ALIST(11),ALIST(12)) ENDIF RETURN END C$FORTRAN MTJEIG *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: EIGCLC.MSC * * AUTHOR: MARK JONES * * PURPOSE: A TRIDIAGONAL EIGENSOLVER CALLED BY LANCZS THAT IS * * EXPLAINED IN JONES-PATRICK * *********************************************************************** SUBROUTINE EIGCLC(J,ALPHA,BET2,THETA,BJ,UNDONE, C ANORM,EPS,DEBUG,HUGE,NTHETA,NBJ) * THE SIZE OF T(J) INTEGER J * ALPHA IS THE DIAGONAL OF T(J) DOUBLE PRECISION ALPHA(*) * BET2 IS THE SQUARE OF THE OFF-DIAGONAL OF T(J) DOUBLE PRECISION BET2(*) * THETA ARE THE RITZ VALUES DOUBLE PRECISION THETA(*) * THE ERROR BOUNDS ON THETA DOUBLE PRECISION BJ(*) * AN ARRAY FOR USE IN THIS ROUTINE ONLY INTEGER UNDONE(*) * THE NORM OF THE MATRIX PENCIL DOUBLE PRECISION ANORM * EPS IS THE MACHINE PRECISION DOUBLE PRECISION EPS * DEBUG LEVEL INTEGER DEBUG * THE LARGEST DOUBLE PRECISION NUMBER DOUBLE PRECISION HUGE * THE NEW RITZ VALUES DOUBLE PRECISION NTHETA(*) * THE NEW ERROR BOUNDS DOUBLE PRECISION NBJ(*) * THE FOLLOWING ARE INTERNAL VARIABLES * THE PROBE FOR NUMLES DOUBLE PRECISION PROBE * HOLDS VALUE FROM NUMHERE INTEGER NMHERE * IS THE EIGENVALUE ISOLATED? LOGICAL OKAY * MINIMUM ERROR TOLERANCE DOUBLE PRECISION ERRTOL * TEMPORARILY HOLDS BJ VALUE DOUBLE PRECISION TEMPBJ * COUNT VARIABLE INTEGER I * ENDS OF INTERVAL DOUBLE PRECISION LEFT, RIGHT * SQRT OF BET2(J+1) DOUBLE PRECISION BETP1 * INTEGER FUNCTIONS INTEGER NUMLES EXTERNAL NUMLES, NEWTON BETP1 = SQRT(BET2(J+1)) * RETURNS EIGENVALUES AND BOUND FROM J=1 OR 2 IF (J.EQ.1) THEN THETA(1) = ALPHA(1) BJ(1) = 1.0D0*BETP1 ELSE IF (J.EQ.2) THEN THETA(1) = (ALPHA(1) + ALPHA(2) - SQRT(4.0D0*BET2(2)+ C (ALPHA(1)-ALPHA(2))*(ALPHA(1)-ALPHA(2))))/2.0D0 THETA(2) = ALPHA(1) + ALPHA(2) - THETA(1) BJ(1) = 1.0D0/(1.0D0+BET2(2)/ C (THETA(1)-ALPHA(1))*(THETA(1)-ALPHA(1))) BJ(2) = 1.0D0/(1.0D0+BET2(2)/ C (THETA(2)-ALPHA(1))*(THETA(2)-ALPHA(1))) BJ(1) = BJ(1)*BETP1 BJ(2) = BJ(2)*BETP1 ENDIF IF (J.GT.2) THEN DO 10 I = 1, J UNDONE(I) = 0 10 CONTINUE * FIND ISOLATED EIGENVALUES AND THE SPOT IN WHICH THEY BELONG DO 20 I = 1, J-1 ERRTOL = ABS(ANORM*SQRT(EPS)*THETA(I)) IF (DEBUG.GT.1) THEN PRINT *,'PRETHET = ',THETA(I),BJ(I),ERRTOL ENDIF IF (BJ(I).LT.ERRTOL) THEN TEMPBJ = ERRTOL ELSE TEMPBJ = BJ(I) ENDIF TEMPBJ = MAX(TEMPBJ + 128.0D0*TEMPBJ*EPS, C ABS(THETA(I)*(16.0D0*EPS))) IF (DEBUG.GT.1) THEN PRINT *,TEMPBJ ENDIF OKAY = .TRUE. IF (I.LT.J-1) THEN IF (2.0D0*TEMPBJ.GE.ABS(THETA(I)-THETA(I+1))) THEN OKAY = .FALSE. ENDIF ENDIF IF (I.GT.1) THEN IF (2.0D0*TEMPBJ.GT.ABS(THETA(I)-THETA(I-1))) THEN OKAY = .FALSE. ENDIF ENDIF IF (OKAY) THEN PROBE = THETA(I) + TEMPBJ NMHERE = NUMLES(ALPHA,BET2,PROBE,J,1,EPS) IF (DEBUG.GT.1) THEN PRINT *,'NUMLES = ',NMHERE,' AT ',I,PROBE ENDIF IF (NMHERE.EQ.I) THEN IF (UNDONE(I).GT.0) THEN IF (DEBUG.GT.1) THEN PRINT *,'OVERWRITING IN T(J) FINDER ',I,PROBE ENDIF ELSE UNDONE(I) = I ENDIF ELSE IF (NMHERE.EQ.I+1) THEN IF (UNDONE(I+1).GT.0) THEN IF (DEBUG.GT.1) THEN PRINT *,'OVERWRITING IN T(J) FINDER ',I,PROBE ENDIF ELSE UNDONE(I+1) = I ENDIF ELSE PRINT *,'WARNING: PROBLEM IN TRIDIAGONAL SYSTEM' PRINT *,'WARNING: ',NMHERE,' TO THE LEFT OF ',I PRINT *,'WARNING: THINGS MAY DETERIORATE' PRINT *,'FIXED: ADJUSTED INTERVALS' ENDIF ENDIF 20 CONTINUE * FIND EIGENVALUES DO 510 I = 1, J IF (DEBUG.GT.1) THEN PRINT *,'UNDONE ',I,UNDONE(I) ENDIF IF (UNDONE(I).EQ.0) THEN IF (I.EQ.1) THEN LEFT = THETA(1) - BJ(1) RIGHT = THETA(1) NTHETA(I) = (LEFT+RIGHT)/2.0D0 NBJ(I) = BJ(I) CALL NEWTON(J,ALPHA,BET2,NTHETA(I),NBJ(I),EPS, C LEFT,RIGHT,DEBUG,I,HUGE) ELSE IF (I.EQ.J) THEN LEFT = THETA(I-1) RIGHT = THETA(I-1) + BJ(I-1) NTHETA(I) = (LEFT+RIGHT)/2.0D0 NBJ(I) = BJ(I) CALL NEWTON(J,ALPHA,BET2,NTHETA(I),NBJ(I),EPS, C LEFT,RIGHT,DEBUG,I,HUGE) ELSE LEFT = THETA(I-1) RIGHT = THETA(I) NTHETA(I) = (THETA(I)+THETA(I-1))/2.0D0 NBJ(I) = BJ(I) CALL NEWTON(J,ALPHA,BET2,NTHETA(I),NBJ(I),EPS, C LEFT,RIGHT,DEBUG,I,HUGE) ENDIF ELSE IF (UNDONE(I).NE.I) THEN ERRTOL = ABS(ANORM*SQRT(EPS)*THETA(I-1)) IF (BJ(I-1).LT.ERRTOL) THEN NBJ(I) = ERRTOL NTHETA(I) = THETA(I-1) ELSE NBJ(I) = BJ(I-1) THETA(I) = THETA(I-1) + (BJ(I-1)/2.0D0) ENDIF LEFT = THETA(I-1) - ABS(THETA(I-1)*EPS*128.0D0) RIGHT = THETA(I-1) + BJ(I-1) ELSE ERRTOL = ABS(ANORM*SQRT(EPS)*THETA(I)) IF (BJ(I).LT.ERRTOL) THEN NBJ(I) = ERRTOL LEFT = THETA(I) - NBJ(I) RIGHT = THETA(I) + ABS(EPS*THETA(I)*128.0D0) ELSE NBJ(I) = BJ(I) LEFT = THETA(I) - BJ(I) RIGHT = THETA(I) + ABS(EPS*THETA(I)*128.0D0) THETA(I) = THETA(I) - (BJ(I)/2.0D0) ENDIF ENDIF CALL NEWTON(J,ALPHA,BET2,NTHETA(I),NBJ(I),EPS, C LEFT,RIGHT,DEBUG,I,HUGE) ENDIF NBJ(I) = NBJ(I)*BETP1 IF (DEBUG.GT.1) THEN PRINT *,'POST = ',NTHETA(I),NBJ(I) ENDIF 510 CONTINUE DO 500 I = 1, J BJ(I) = NBJ(I) THETA(I) = NTHETA(I) 500 CONTINUE ENDIF RETURN END C$FORTRAN EIGMAT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: EIGMAT.MSC * * AUTHOR: MARK JONES * * PURPOSE: MATRIX ROUTINES USED IN EIGENVALUE CALCULATIONS * *********************************************************************** * SEVERAL ROUTINES ASSOCIATED WITH EIGENVECTOR * CALCULATIONS * A ROUTINE TO MULTIPLY A TRIDIAGONAL MATRIX, T, BY A VECTOR SUBROUTINE TRIMLT(N,ALPHA,BETA,RESULT,INVEC) * THE DIMENSION OF T INTEGER N * THE DIAGONAL AND SUBDIAGONAL OF T DOUBLE PRECISION ALPHA(*), BETA(*) * RESULT VECTOR DOUBLE PRECISION RESULT(*) * IN VECTOR DOUBLE PRECISION INVEC(*) * INTERNAL VARIABLES * ALL COUNT VARIABLES INTEGER I IF (N.EQ.0) RETURN IF (N.EQ.1) THEN RESULT(1) = ALPHA(1)*INVEC(1) RETURN ENDIF RESULT(1) = ALPHA(1)*INVEC(1) + BETA(2)*INVEC(2) DO 10 I = 2, N-1 RESULT(I) = BETA(I)*INVEC(I-1) + ALPHA(I)*INVEC(I) + C BETA(I+1)*INVEC(I+1) 10 CONTINUE RESULT(N) = BETA(N)*INVEC(N-1) + ALPHA(N)*INVEC(N) RETURN END * A ROUTINE TO MULTIPLY A FULL MATRIX BY A VECTOR SUBROUTINE FLLMLT(LDI,N,M,RESULT,MAT,INVEC,IOPTN) * THE LEADING INDEX INTEGER LDI * THE NUMBER OF ROWS INTEGER N * THE NUMBER OF COLUMNS INTEGER M * THE RESULT VECTOR DOUBLE PRECISION RESULT(*) * THE MATRIX DOUBLE PRECISION MAT(LDI,*) * THE IN VECTOR DOUBLE PRECISION INVEC(*) * MULTIPLY BY MAT OR TRANSPOSE OF MAT INTEGER IOPTN * INTERNAL VARIABLES * ALL COUNT VARIABLES INTEGER I,J IF (IOPTN.EQ.0) THEN DO 5 I = 1, N RESULT(I) = 0.0D0 5 CONTINUE DO 10 I = 1, M DO 20 J = 1, N RESULT(J) = RESULT(J) + MAT(J,I)*INVEC(I) 20 CONTINUE 10 CONTINUE ELSE DO 30 I = 1, M RESULT(I) = 0.0D0 DO 40 J = 1, N RESULT(I) = RESULT(I) + MAT(J,I)*INVEC(J) 40 CONTINUE 30 CONTINUE ENDIF RETURN END * A ROUTINE FOR COMPUTING EIGENVECTORS FROM S AND Q SUBROUTINE CMPVEC(N,Q,QLAST,S,ALPHA,BETA,THETA,Y,PROB) * THE ORDER OF THE MATRIX INTEGER N * THE Q(J) ARRAY DOUBLE PRECISION Q(N,1) * THE LAST INDEX OF THE Q ARRAY INTEGER QLAST * THE S VECTOR DOUBLE PRECISION S(*) * DIAGONAL OF T(J) DOUBLE PRECISION ALPHA(*) * OFF DIAGONAL OF T(J) DOUBLE PRECISION BETA(*) * THE EIGENVALUE DOUBLE PRECISION THETA * THE EIGENVECTOR DOUBLE PRECISION Y(*) * THE TYPE OF TRANSFORMATION INTEGER PROB * THE FOLLOWING ARE INTERNAL VARIABLES * COMPUTE THE ADJUSTED VECTOR, W, FROM S AS SUGGESTED BY PARLETT * W(1) = ALPHA(1)*S(1) + BETA(2)*S(2) * DO 5 I = 2, QLAST-1 * W(I) = BETA(I)*S(I-1) + ALPHA(I)*S(I) + * C BETA(I+1)*S(I+1) *5 CONTINUE * IF (QLAST.GT.1) THEN * W(QLAST) = BETA(QLAST)*S(QLAST-1) + * C ALPHA(QLAST)*S(QLAST) * ENDIF * W(QLAST+1) = S(QLAST) * BETA(QLAST+1) * DO 8 I = 1, QLAST+1 * W(I) = W(I) / THETA *8 CONTINUE IF (PROB.EQ.1) THEN S(QLAST+1) = (S(QLAST) * BETA(QLAST+1))/(THETA-1) ELSE S(QLAST+1) = (S(QLAST) * BETA(QLAST+1))/THETA ENDIF * DO 50 I = 1, QLAST+1 * PRINT *,'S = ',S(I) *50 CONTINUE * NOW COMPUTE Y FROM Q*W CALL FLLMLT(N,N,QLAST+1,Y,Q,S,0) RETURN END C$FORTRAN NWSHFT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: FNDSHT.MSC * * AUTHOR: MARK JONES * * PURPOSE: FINDS A NEW SHIFT(S) FOR LANZ * *********************************************************************** * PREVIOUS TO CALLING THE ROUTINE, WE MAY HAVE A LEFT SHIFT AND * A RIGHT SHIFT AND THE PURPOSE OF THIS ROUTINE IS TO FIND GOOD * NEW LEFT AND RIGHT SHIFTS. IT IS POSSIBLE TO NOT HAVE A NEW * SHIFT AT EITHER OR BOTH POSITIONS. THE INFORMATION USED IF * FROM THE OLD EIGENVALUES AND THE LATEST RUNS (R1 AND R2) * AT THE LEFT AND RIGHT SHIFTS SUBROUTINE NWSHFT(J,THETA,BJ,R1J,R1THET,R1BJ,R2J,R2THET,R2BJ, C LFTVAL,RGHTVL,NWLEFT,NWRGHT,DEBUG,KNORM,MNORM, C EPS,DELTA,OSIGMA) * THE ORDER OF THE TRIDIAGONAL MATRICES INTEGER J, R1J, R2J * THE EIGENVALUES FOUND SO FAR DOUBLE PRECISION THETA(*), R1THET(*), R2THET(*) * THE ERROR BOUNDS ON THESE EIGENVALUES DOUBLE PRECISION BJ(*), R1BJ(*), R2BJ(*) * CURRENT LEFT EDGE AND CURRENT RIGHT EDGE DOUBLE PRECISION LFTVAL, RGHTVL * DID WE UPDATE THE LEFT OR RIGHT EDGES LOGICAL NWLEFT, NWRGHT * THE DEBUGGING LEVEL INTEGER DEBUG * THE NORMS OF K AND M DOUBLE PRECISION KNORM, MNORM * THE MACHINE EPS DOUBLE PRECISION EPS * THE DESIRED ACCURACY FOR THE EIGENVALUES DOUBLE PRECISION DELTA * THE ORIGINAL SIGMA DOUBLE PRECISION OSIGMA * SOME INTERNAL VARIABLES * CONVERGED BOUNDARIES DOUBLE PRECISION CLEFT, CRIGHT * UNCONVERGED BOUNDARIES DOUBLE PRECISION UNCLFT, UNCRGT * ERROR BOUNDS FOR ABOVE DOUBLE PRECISION UNCLBJ, UNCRBJ * FOUND VALUES TO THE LEFT OR RIGHT LOGICAL FLEFT, FRIGHT * THE MINIMUM DISTANCE THAT A SHIFT MAY BE FROM A POSSIBLE * EIGENVALUE DOUBLE PRECISION MNDIST * THE MAXIMUM PERCENTAGE OF THE EIGENVALUE THAT THE ERROR BOUND * MAY BE, BEFORE WE IGNORE IT DOUBLE PRECISION FRACT * THE OLD VALUES OF PARAMETERS DESCRIBED ABOVE LOGICAL ONWRGT, ONWLFT DOUBLE PRECISION ORGTVL, OLFTVL * SOME PARAMETERS USED TO DETERMINE WHERE TO TAKE A SHIFT DOUBLE PRECISION DELERR, ENU, ENORM EXTERNAL CHKBND, ADJSHT * FIND WHERE UNCONVERGED EIGENVALUE BOUNDARIES ARE FRACT = 0.10D0 CLEFT = LFTVAL CRIGHT = RGHTVL UNCLFT = LFTVAL UNCRGT = RGHTVL UNCLBJ = 0.0D0 UNCRBJ = 0.0D0 FLEFT = .FALSE. FRIGHT = .FALSE. CALL CHKBND(J,THETA,BJ,CLEFT,CRIGHT,UNCLFT,UNCRGT, C UNCLBJ,UNCRBJ,LFTVAL,RGHTVL,FRACT,OSIGMA,FLEFT,FRIGHT) CALL CHKBND(R1J,R1THET,R1BJ,CLEFT,CRIGHT,UNCLFT,UNCRGT, C UNCLBJ,UNCRBJ,LFTVAL,RGHTVL,FRACT,OSIGMA,FLEFT,FRIGHT) CALL CHKBND(R2J,R2THET,R2BJ,CLEFT,CRIGHT,UNCLFT,UNCRGT, C UNCLBJ,UNCRBJ,LFTVAL,RGHTVL,FRACT,OSIGMA,FLEFT,FRIGHT) IF (DEBUG.GT.0) THEN PRINT *,'UNCLEFT, UNCRIGHT',UNCLFT,UNCRGT,CLEFT,CRIGHT PRINT *,'FRIGHT, FLEFT',FRIGHT,FLEFT ENDIF * DETERMINE LEFT SHIFT IF ((.NOT.FLEFT).AND.(CLEFT.EQ.LFTVAL)) THEN * NO EIGENVALUES TO THE LEFT THAT ARE CLOSE ENOUGH TO DETECT NWLEFT = .FALSE. ELSE IF (.NOT.FLEFT) THEN * NO UNCONVERGED EIGENVALUES TO THE LEFT THAT ARE CLOSE, TAKE * A SHIFT EQUAL TO OUR CONF. INTERVAL TO TRY AGAIN NWLEFT = .FALSE. * NWLEFT = .TRUE. * LFTVAL = MIN(LFTVAL-MNDIST,LFTVAL-2*(LFTVAL-CLEFT)) ELSE * SOME UNCONVERGED VALUES TO THE LEFT, FIND A GAP NEAR 1ST ONE MNDIST = (1.0D0/(DELTA/UNCLFT)) * C ((KNORM - (MNORM*UNCLFT))*EPS) MNDIST = MAX(MNDIST,0.001D0*UNCLFT) IF (DEBUG.GT.0) THEN PRINT *,'EST NORM = ',KNORM - (MNORM*UNCLFT) PRINT *,'RES EST = ',DELTA/UNCLFT PRINT *,'EST COND = ',(KNORM -(MNORM*UNCLFT))/MNDIST PRINT *,'MNDIST = ',MNDIST ENDIF ONWLFT = NWLEFT OLFTVL = LFTVAL NWLEFT = .TRUE. CALL ADJSHT(LFTVAL,UNCLFT,UNCLBJ,MNDIST,OSIGMA, C J,THETA,BJ,R1J,R1THET,R1BJ,R2J,R2THET,R2BJ,FRACT) IF (ONWLFT) THEN IF (ABS(OLFTVL-UNCLFT).LT.ABS(LFTVAL-UNCLFT)) THEN PRINT *,'ERROR: MACH. PREC. TOO LOW FOR THIS ACCURACY' PRINT *,'REMEDY: REQUEST A LOWER EIGENPAIR ACCURACY' NWLEFT = .FALSE. ENDIF ENDIF ENDIF * DETERMINE RIGHT SHIFT IF ((.NOT.FRIGHT).AND.(CRIGHT.EQ.RGHTVL)) THEN * NO EIGENVALUES TO THE RIGHT THAT ARE CLOSE ENOUGH TO DETECT NWRGHT = .FALSE. ELSE IF (.NOT.FRIGHT) THEN * NO UNCONVERGED EIGENVALUES TO THE RIGHT THAT ARE CLOSE, TAKE * A SHIFT EQUAL TO OUR CONF. INTERVAL TO TRY AGAIN NWRGHT = .FALSE. * NWRGHT = .TRUE. * RGHTVL = MIN(RGHTVL-MNDIST,RGHTVL- * C 2*(RGHTVL-CRIGHT)) ELSE * SOME UNCONVERGED VALUES TO THE RIGHT, FIND A GAP NEAR 1ST ONE MNDIST = (1.0D0/(DELTA/UNCRGT)) * C ((KNORM - (MNORM*UNCRGT))*EPS) MNDIST = MAX(MNDIST,0.001D0*UNCRGT) IF (DEBUG.GT.0) THEN PRINT *,'EST NORM = ',KNORM - (MNORM*UNCRGT) PRINT *,'RES EST = ',DELTA/UNCRGT PRINT *,'EST COND = ',(KNORM -(MNORM*UNCRGT))/MNDIST PRINT *,'MNDIST = ',MNDIST PRINT *,'TARGET = ',UNCRGT,UNCRBJ PRINT *,'NORMS = ',KNORM,MNORM PRINT *,'A NORM = ',KNORM - (MNORM*UNCRGT) PRINT *,'DELTA = ',DELTA,DELTA*UNCRGT ENU = 1.0D0/MNDIST PRINT *,'MNDIST = ',MNDIST,ENU ENORM = MNORM*(((1.0D0+42*EPS)/ C (MNDIST-EPS*1800*42*42*KNORM))-ENU) PRINT *,'ENORM = ',ENORM DELERR = (1.0D0/(ENU+ENORM)) - (1.0D0/ENU) PRINT *,'EIG ERROR = ',DELERR,DELERR/UNCRGT ENDIF ONWRGT = NWRGHT ORGTVL = RGHTVL NWRGHT = .TRUE. CALL ADJSHT(RGHTVL,UNCRGT,UNCRBJ,MNDIST,OSIGMA, C J,THETA,BJ,R1J,R1THET,R1BJ,R2J,R2THET,R2BJ,FRACT) IF (ONWRGT) THEN IF (ABS(ORGTVL-UNCRGT).LT.ABS(RGHTVL-UNCRGT)) THEN PRINT *,'ERROR: MACH. PREC. TOO LOW FOR THIS ACCURACY' PRINT *,'REMEDY: REQUEST A LOWER EIGENPAIR ACCURACY' NWRGHT = .FALSE. ENDIF ENDIF ENDIF * IF LEFT AND RIGHT GOT MIXED UP THEN SWITCH THEM IF (RGHTVL.LT.LFTVAL) THEN UNCRGT = RGHTVL FRIGHT = NWRGHT RGHTVL = LFTVAL NWRGHT = NWLEFT LFTVAL = RGHTVL NWLEFT = NWRGHT ENDIF * IF LEFT AND RIGHT ARE VERY CLOSE, THEN COMPACT THEM IF ((ABS(RGHTVL-LFTVAL).LT.MNDIST).AND. C NWRGHT.AND.NWLEFT) THEN NWLEFT = .FALSE. ENDIF RETURN END * THIS SUBROUTINE ENSURES THAT THE SHIFT IS NOT TOO CLOSE * TO AN EIGENVALUE THAT WE KNOW ABOUT AND IS STILL AS NEAR * TO THE GUESS AS POSSIBLE SUBROUTINE ADJSHT(SHIFT,TARGET,TRGTBJ,MNDIST,OSIGMA,J,THETA, C BJ,R1J,R1THET,R1BJ,R2J,R2THET,R2BJ,FRACT) * SHIFT IS THE VALUE THAT WE ARE TRYING TO FIND DOUBLE PRECISION SHIFT * TARGET TO GET NEAR TO DOUBLE PRECISION TARGET * THE BJ OF THE TARGET DOUBLE PRECISION TRGTBJ * THE MINIMUM DISTANCE FROM A EIGENVALUE ALLOWED DOUBLE PRECISION MNDIST * THE ORIGINAL SIGMA DOUBLE PRECISION OSIGMA * OTHERS ARE DESCRIBED ABOVE INTEGER R1J, R2J, J DOUBLE PRECISION R1THET(*), R2THET(*), THETA(*) DOUBLE PRECISION R1BJ(*), R2BJ(*), BJ(*) * THE PERCENTAGE ERROR AT WHICH TO IGNORE AN EIGENVALUE DOUBLE PRECISION FRACT * INTERNAL VARIABLES * SIZE OF GAP TO THE LEFT AND RIGHT DOUBLE PRECISION RGAP, LGAP * THE NEXT VALUE TO EXAMINE DOUBLE PRECISION NEXT, NEXTBJ * IS THERE A NEXT VALUE? LOGICAL IFNEXT * THE CURRENT SHIFT BEING EXAMINED DOUBLE PRECISION GUESS, GSSBJ * SHOULD WE FAVOR THE LEFT OR RIGHT? LOGICAL FAVORL EXTERNAL FNDGAP GUESS = TARGET GSSBJ = TRGTBJ IF (GUESS.GT.OSIGMA) THEN FAVORL = .TRUE. ELSE FAVORL = .FALSE. ENDIF 10 CONTINUE CALL FNDGAP(MNDIST,TARGET,GUESS,GSSBJ,RGAP,LGAP,NEXT,NEXTBJ, C IFNEXT,J,THETA,BJ,R1J,R1THET,R1BJ,R2J,R2THET,R2BJ,FRACT) IF (IFNEXT) THEN IF ((FAVORL).AND.(ABS(LGAP).GT.2*MNDIST)) THEN SHIFT = GUESS - ABS(GSSBJ) - MNDIST ELSE IF ((.NOT.(FAVORL)).AND.(ABS(RGAP).GT.2*MNDIST)) THEN SHIFT = GUESS + ABS(GSSBJ) + MNDIST ELSE IF (ABS(RGAP).GT.2*MNDIST) THEN SHIFT = GUESS + ABS(GSSBJ) + MNDIST ELSE IF (ABS(LGAP).GT.2*MNDIST) THEN SHIFT = GUESS - ABS(GSSBJ) - MNDIST ELSE GUESS = NEXT GSSBJ = NEXTBJ GOTO 10 ENDIF ELSE SHIFT = GUESS + ((GUESS-TARGET)/ABS(GUESS-TARGET))* C (ABS(GSSBJ) + MNDIST) ENDIF RETURN END * FIND THE SIZE OF A GAP SUBROUTINE FNDGAP(MNDIST,TARGET,VALUE,VALBJ,RGAP,LGAP,NEXT, C NEXTBJ,IFNEXT,J,THETA,BJ,R1J,R1THET,R1BJ,R2J,R2THET,R2BJ,FRACT) * THE SMALLEST INTERVAL ALLOWED DOUBLE PRECISION MNDIST * THE VALUE THAT WE ARE TRYING TO GET CLOSE TO DOUBLE PRECISION TARGET * THE VALUE TO START AT DOUBLE PRECISION VALUE * BJ OF THE VALUE WE ARE STARTING AT DOUBLE PRECISION VALBJ * THE GAP FOUND DOUBLE PRECISION LGAP, RGAP * THE NEXT VALUE IN ORDER DOUBLE PRECISION NEXT * THE BJ OF THE NEXT DOUBLE PRECISION NEXTBJ * IS THERE A NEXT VALUE? LOGICAL IFNEXT * THE REST ARE DESCRIBED ELSEWHERE INTEGER R1J, R2J, J DOUBLE PRECISION R1THET(*), R2THET(*), THETA(*) DOUBLE PRECISION R1BJ(*), R2BJ(*), BJ(*) * THE PERCENTAGE ERROR AT WHICH TO IGNORE AN EIGENVALUE DOUBLE PRECISION FRACT * INTERNAL VARIABLES * INDICATES IF VALUES HAVE BEEN FOUND LOGICAL FNDRGP, FNDLGP EXTERNAL GETNXT, CLCGAP FNDRGP = .FALSE. FNDLGP = .FALSE. IFNEXT = .FALSE. LGAP = 0.0D0 RGAP = 0.0D0 CALL GETNXT(J,THETA,BJ,TARGET,VALUE,IFNEXT,NEXT,NEXTBJ) CALL GETNXT(R1J,R1THET,R1BJ,TARGET,VALUE,IFNEXT,NEXT,NEXTBJ) CALL GETNXT(R2J,R2THET,R2BJ,TARGET,VALUE,IFNEXT,NEXT,NEXTBJ) CALL CLCGAP(J,THETA,BJ,VALUE,VALBJ,LGAP,RGAP,FNDLGP,FNDRGP, C FRACT) CALL CLCGAP(R1J,R1THET,R1BJ,VALUE,VALBJ,LGAP,RGAP,FNDLGP,FNDRGP, C FRACT) CALL CLCGAP(R2J,R2THET,R2BJ,VALUE,VALBJ,LGAP,RGAP,FNDLGP,FNDRGP, C FRACT) RETURN END * NO LONGER CALLED, BUT REMAINS JUST IN CASE * A SUBROUTINE TO FIND THE MINIMUM AND MAXIMUM EIGENVALUES INTEGER FUNCTION GETRNG(J,THETA,BJ,MINEIG,MAXEIG,FRANGE,FRACT) * THE NUMBER OF VALUES IN THETA AND BJ INTEGER J * THE EIGENVALUE ESTIMATES DOUBLE PRECISION THETA(*) * THE ERROR BOUNDS FOR THETA DOUBLE PRECISION BJ(*) * THE CURRENT MINIMUM DOUBLE PRECISION MINEIG * THE CURRENT MAXIMUM DOUBLE PRECISION MAXEIG * INDICATES IF A RANGE HAS BEEN FOUND LOGICAL FRANGE * THE PERCENTAGE ACCURACY REQUIRED OF AN EIGENVALUE DOUBLE PRECISION FRACT * INTERNAL VARIABLES * COUNT VARIABLE INTEGER I * THE NUMBER OF EIGENVALUES INTEGER NUMEIG NUMEIG = 0 DO 10 I = 1, J IF (ABS(BJ(I)).GT.FRACT*ABS(THETA(I))) GOTO 10 IF (BJ(I).LT.0.0D0) THEN NUMEIG = NUMEIG + 1 ENDIF IF (FRANGE) THEN IF (THETA(I)+ABS(BJ(I)).LT.MINEIG) THEN MINEIG = THETA(I)+ABS(BJ(I)) ENDIF IF (THETA(I)-ABS(BJ(I)).GT.MAXEIG) THEN MAXEIG = THETA(I)-ABS(BJ(I)) ENDIF ELSE MINEIG = THETA(I)+ABS(BJ(I)) MAXEIG = THETA(I)-ABS(BJ(I)) FRANGE = .TRUE. ENDIF 10 CONTINUE GETRNG = NUMEIG RETURN END * A SUBROUTINE TO FIND THE BOUNDS OF THE EIGENVALUES THAT WE * HAVE FOUND THUS FAR SUBROUTINE CHKBND(J,THETA,BJ,CLEFT,CRIGHT,UNCLFT,UNCRGT, C UNCLBJ,UNCRBJ,LFTVAL,RGHTVL,FRACT,OSIGMA, C FLEFT,FRIGHT) * THE NUMBER OF VALUES IN THETA AND BJ INTEGER J * THE EIGENVALUE ESTIMATES DOUBLE PRECISION THETA(*) * THE EIGENVALUE BOUNDS DOUBLE PRECISION BJ(*) * THE LEFT (RIGHT) CONVERGED BOUNDARY DOUBLE PRECISION CLEFT,CRIGHT * THE LEFT (RIGHT) UNCONVERGED BOUNDARY DOUBLE PRECISION UNCLFT,UNCRGT * THE LEFT (RIGHT) UNCONVERGED BOUNDARY ERROR BOUNDS DOUBLE PRECISION UNCLBJ,UNCRBJ * THE PREVIOUS LEFT (RIGHT) SHIFT DOUBLE PRECISION LFTVAL,RGHTVL * THE PERCENTAGE ACCURACY THAT AN EIGENVALUE MUST HAVE TO BE * CONSIDERED DOUBLE PRECISION FRACT * THE ORIGINAL SIGMA DOUBLE PRECISION OSIGMA * HAVE WE FOUND A LEFT (RIGHT) VALUE LOGICAL FLEFT, FRIGHT * INTERNAL DECLARATIONS * A LOOP INDEX INTEGER I DO 10 I = 1, J * THROW OUT EIGENVALUE? IF (ABS(BJ(I)).GT.FRACT*ABS(THETA(I))) GOTO 10 IF (BJ(I).LT.0.0D0) THEN * UNCONVERGED EIGENVALUE TREATEMENT IF (THETA(I).LT.OSIGMA) THEN IF (FLEFT) THEN IF (THETA(I).GT.UNCLFT) THEN UNCLFT = THETA(I) UNCLBJ = BJ(I) ENDIF ELSE UNCLFT = THETA(I) UNCLBJ = BJ(I) FLEFT = .TRUE. ENDIF ELSE IF (THETA(I).GT.OSIGMA) THEN IF (FRIGHT) THEN IF (THETA(I).LT.UNCRGT) THEN UNCRGT = THETA(I) UNCRBJ = BJ(I) ENDIF ELSE UNCRGT = THETA(I) UNCRBJ = BJ(I) FRIGHT = .TRUE. ENDIF ENDIF ELSE * CONVERGED EIGENVALUE TREATEMENT IF (THETA(I).LT.CLEFT) THEN CLEFT = THETA(I) ELSE IF (THETA(I).GT.CRIGHT) THEN CRIGHT = THETA(I) ENDIF ENDIF 10 CONTINUE RETURN END * A ROUTINE TO FIND THE NEXT SEARCH POSITION SUBROUTINE GETNXT(J,THETA,BJ,TARGET,VALUE,IFNEXT,NEXT,NEXTBJ) * THE NUMBER OF VALUES IN THETA AND BJ INTEGER J * THE EIGENVALUE ESTIMATES DOUBLE PRECISION THETA(*) * THE EIGENVALUE ERROR BOUNDS DOUBLE PRECISION BJ(*) * THE TARGET POSITION WE ORIGINALLY WANTED DOUBLE PRECISION TARGET * THE POSITION THAT WE ARE LOOKING AT DOUBLE PRECISION VALUE * DO WE HAVE A NEXT? LOGICAL IFNEXT * THE NEXT VALUE DOUBLE PRECISION NEXT * THE NEXT ERROR BOUND DOUBLE PRECISION NEXTBJ * INTERNAL VARIABLES * COUNT VARIABLE INTEGER I DO 10 I = 1, J IF (ABS(TARGET-THETA(I)).GT.ABS(TARGET-VALUE)) THEN IF (IFNEXT) THEN IF (ABS(TARGET-THETA(I)).LT.ABS(TARGET-NEXT)) THEN NEXT = THETA(I) NEXTBJ = BJ(I) ENDIF ELSE NEXT = THETA(I) NEXTBJ = BJ(I) IFNEXT = .TRUE. ENDIF ENDIF 10 CONTINUE RETURN END * A ROUTINE FOR CALCULATING THE SIZE OF THE GAP SUBROUTINE CLCGAP(J,THETA,BJ,VALUE,VALBJ,LGAP,RGAP, C FNDLGP,FNDRGP,FRACT) * THE NUMBER OF VALUES IN THETA AND BJ INTEGER J * THE EIGENVALUE ESTIMATES DOUBLE PRECISION THETA(*) * THE EIGENVALUE ERROR BOUNDS DOUBLE PRECISION BJ(*) * THE TARGET POSITION WE ARE LOOKING AT DOUBLE PRECISION VALUE * THE ERROR BOUND OF THE POSITION DOUBLE PRECISION VALBJ * THE CURRENT LEFT (RIGHT) GAPS DOUBLE PRECISION LGAP, RGAP * HAVE WE FOUND A LEFT (RIGHT) GAP LOGICAL FNDLGP, FNDRGP * THE PERCENTAGE ERROR AT WHICH TO IGNORE AN EIGENVALUE DOUBLE PRECISION FRACT * INTERNAL VARIABLES * COUNT VARIABLE INTEGER I * A TEMPORARY VARIABLE DOUBLE PRECISION TRGAP, TLGAP * HOLD VALUE FROM GETREL INTEGER RELATE * INTEGER FUNCTIONS INTEGER GETREL EXTERNAL GETREL DO 10 I = 1, J RELATE = GETREL(VALUE,THETA(I)) IF (ABS(BJ(I)).GT.FRACT*ABS(THETA(I))) GOTO 10 IF (RELATE.EQ.0) THEN IF ((VALUE-ABS(VALBJ)).GT.(THETA(I)+ABS(BJ(I)))) THEN TLGAP = (VALUE-ABS(VALBJ))-(THETA(I)+ABS(BJ(I))) ELSE TLGAP = 0.0D0 ENDIF IF (FNDLGP) THEN IF (ABS(TLGAP).LT.ABS(LGAP)) THEN LGAP = TLGAP ENDIF ELSE FNDLGP = .TRUE. LGAP = TLGAP ENDIF ELSE IF (RELATE.EQ.2) THEN IF ((VALUE+ABS(VALBJ)).LT.(THETA(I)-ABS(BJ(I)))) THEN TRGAP = (VALUE+ABS(VALBJ))-(THETA(I)-ABS(BJ(I))) ELSE TRGAP = 0.0D0 ENDIF IF (FNDRGP) THEN IF (ABS(TRGAP).LT.ABS(RGAP)) THEN RGAP = TRGAP ENDIF ELSE FNDRGP = .TRUE. RGAP = TRGAP ENDIF ENDIF 10 CONTINUE RETURN END * RETURNS RELATIONS OF VAL1 TO VAL2 * 0 IF VAL1 > VAL2 * 1 IF VAL1 ~= VAL2 * 2 IF VAL1 < VAL2 INTEGER FUNCTION GETREL(VAL1,VAL2) DOUBLE PRECISION VAL1, VAL2 IF (VAL1.EQ.VAL2) THEN GETREL = 1 ELSE IF (VAL1.GT.VAL2) THEN GETREL = 0 ELSE IF (VAL1.LT.VAL2) THEN GETREL = 2 ENDIF RETURN END C$FORTRAN GENQMD *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: GENQMD.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: SEE BELOW * *********************************************************************** C----- SUBROUTINE GENQMD C**************************************************************** C**************************************************************** C********** GENQMD ..... QUOT MIN DEGREE ORDERING ********* C**************************************************************** C**************************************************************** C C PURPOSE - THIS ROUTINE IMPLEMENTS THE MINIMUM DEGREE C ALGORITHM. IT MAKES USE OF THE IMPLICIT REPRESENT- C ATION OF THE ELIMINATION GRAPHS BY QUOTIENT GRAPHS, C AND THE NOTION OF INDISTINGUISHABLE NODES. C CAUTION - THE ADJACENCY VECTOR ADJNCY WILL BE C DESTROYED. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. C C OUTPUT PARAMETERS - C PERM - THE MINIMUM DEGREE ORDERING. C INVP - THE INVERSE OF PERM. C C WORKING PARAMETERS - C DEG - THE DEGREE VECTOR. DEG(I) IS NEGATIVE MEANS C NODE I HAS BEEN NUMBERED. C MARKER - A MARKER VECTOR, WHERE MARKER(I) IS C NEGATIVE MEANS NODE I HAS BEEN MERGED WITH C ANOTHER NODE AND THUS CAN BE IGNORED. C RCHSET - VECTOR USED FOR THE REACHABLE SET. C NBRHD - VECTOR USED FOR THE NEIGHBORHOOD SET. C QSIZE - VECTOR USED TO STORE THE SIZE OF C INDISTINGUISHABLE SUPERNODES. C QLINK - VECTOR TO STORE INDISTINGUISHABLE NODES, C I, QLINK(I), QLINK(QLINK(I)) ... ARE THE C MEMBERS OF THE SUPERNODE REPRESENTED BY I. C C PROGRAM SUBROUTINES - C QMDRCH, QMDQT, QMDUPD. C C**************************************************************** C C SUBROUTINE GENQMD ( NEQNS, XADJ, ADJNCY, PERM, INVP, DEG, 1 MARKER, RCHSET, NBRHD, QSIZE, QLINK, 1 NOFSUB ) C C**************************************************************** C INTEGER ADJNCY(1), PERM(1), INVP(1), DEG(1), MARKER(1), 1 RCHSET(1), NBRHD(1), QSIZE(1), QLINK(1) INTEGER XADJ(1), INODE, IP, IRCH, J, MINDEG, NDEG, 1 NEQNS, NHDSZE, NODE, NOFSUB, NP, NUM, NUMP1, 1 NXNODE, RCHSZE, SEARCH, THRESH C C**************************************************************** C C ----------------------------------------------------- C INITIALIZE DEGREE VECTOR AND OTHER WORKING VARIABLES. C ----------------------------------------------------- MINDEG = NEQNS NOFSUB = 0 DO 100 NODE = 1, NEQNS PERM(NODE) = NODE INVP(NODE) = NODE MARKER(NODE) = 0 QSIZE(NODE) = 1 QLINK(NODE) = 0 NDEG = XADJ(NODE+1) - XADJ(NODE) DEG(NODE) = NDEG IF ( NDEG .LT. MINDEG ) MINDEG = NDEG 100 CONTINUE NUM = 0 C ----------------------------------------------------- C PERFORM THRESHOLD SEARCH TO GET A NODE OF MIN DEGREE. C VARIABLE SEARCH POINTS TO WHERE SEARCH SHOULD START. C ----------------------------------------------------- 200 SEARCH = 1 THRESH = MINDEG MINDEG = NEQNS 300 NUMP1 = NUM + 1 IF ( NUMP1 .GT. SEARCH ) SEARCH = NUMP1 DO 400 J = SEARCH, NEQNS NODE = PERM(J) IF ( MARKER(NODE) .LT. 0 ) GOTO 400 NDEG = DEG(NODE) IF ( NDEG .LE. THRESH ) GO TO 500 IF ( NDEG .LT. MINDEG ) MINDEG = NDEG 400 CONTINUE GO TO 200 C --------------------------------------------------- C NODE HAS MINIMUM DEGREE. FIND ITS REACHABLE SETS BY C CALLING QMDRCH. C --------------------------------------------------- 500 SEARCH = J NOFSUB = NOFSUB + DEG(NODE) MARKER(NODE) = 1 CALL QMDRCH (NODE, XADJ, ADJNCY, DEG, MARKER, 1 RCHSZE, RCHSET, NHDSZE, NBRHD ) C ------------------------------------------------ C ELIMINATE ALL NODES INDISTINGUISHABLE FROM NODE. C THEY ARE GIVEN BY NODE, QLINK(NODE), .... C ------------------------------------------------ NXNODE = NODE 600 NUM = NUM + 1 NP = INVP(NXNODE) IP = PERM(NUM) PERM(NP) = IP INVP(IP) = NP PERM(NUM) = NXNODE INVP(NXNODE) = NUM DEG(NXNODE) = - 1 NXNODE = QLINK(NXNODE) IF (NXNODE .GT. 0) GOTO 600 C IF ( RCHSZE .LE. 0 ) GO TO 800 C ------------------------------------------------ C UPDATE THE DEGREES OF THE NODES IN THE REACHABLE C SET AND IDENTIFY INDISTINGUISHABLE NODES. C ------------------------------------------------ CALL QMDUPD ( XADJ, ADJNCY, RCHSZE, RCHSET, DEG, 1 QSIZE, QLINK, MARKER, RCHSET(RCHSZE+1), 1 NBRHD(NHDSZE+1) ) C ------------------------------------------- C RESET MARKER VALUE OF NODES IN REACH SET. C UPDATE THRESHOLD VALUE FOR CYCLIC SEARCH. C ALSO CALL QMDQT TO FORM NEW QUOTIENT GRAPH. C ------------------------------------------- MARKER(NODE) = 0 DO 700 IRCH = 1, RCHSZE INODE = RCHSET(IRCH) IF ( MARKER(INODE) .LT. 0 ) GOTO 700 MARKER(INODE) = 0 NDEG = DEG(INODE) IF ( NDEG .LT. MINDEG ) MINDEG = NDEG IF ( NDEG .GT. THRESH ) GOTO 700 MINDEG = THRESH THRESH = NDEG SEARCH = INVP(INODE) 700 CONTINUE IF ( NHDSZE .GT. 0 ) CALL QMDQT ( NODE, XADJ, 1 ADJNCY, MARKER, RCHSZE, RCHSET, NBRHD ) 800 IF ( NUM .LT. NEQNS ) GO TO 300 RETURN END C$FORTRAN GETIND *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: GETIND.MSC * * AUTHOR: MARK JONES * * PURPOSE: FINDS THE FIRST UNUSED SPACE IN THE EIGENVECTOR ARRAY * *********************************************************************** INTEGER FUNCTION GETIND(YMAXS,J,NUMT,ONUMT,WORKV) * THE MAXIMUM # OF Y VECTORS INTEGER YMAXS * THE CURRENT # OF ELEMENTS IN NUMT INTEGER J * THE VECTOR OF Y INDICES INTEGER NUMT(*) * THE VECTOR OF OLD Y INDICES INTEGER ONUMT(*) * A WORK VECTOR LOGICAL WORKV(*) * INTERNAL VARIABLES INTEGER I DO 10 I = 1, YMAXS WORKV(I) = .FALSE. 10 CONTINUE DO 20 I = 1, J IF (NUMT(I).GT.0) THEN WORKV(NUMT(I)) = .TRUE. ENDIF 20 CONTINUE DO 25 I = 1, YMAXS IF (ONUMT(I).GT.0) THEN WORKV(ONUMT(I)) = .TRUE. ENDIF 25 CONTINUE DO 30 I = 1, YMAXS IF (.NOT. WORKV(I)) THEN GETIND = I RETURN ENDIF 30 CONTINUE GETIND = -1 PRINT *,'ERROR: NO MORE SPACE FOR EIGENVECTORS' PRINT *,'REMEDY: INCREASE YSTORE' RETURN END C$FORTRAN GETNRM *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: GETNRM.MSC * * AUTHOR: MARK JONES * * PURPOSE: FIND THE NORM OF K AND M * *********************************************************************** SUBROUTINE GETNRM(N,KSUM2,MSUM2,KNORM2,MNORM2, C KDIAG,K,KRP,KCP,TK,TKRP,TKCP,MDIAG,M,MRP,MCP,TM,TMRP,TMCP) * N IS THE ORDER OF THE MATRIX INTEGER N * WORK VECTORS FOR COMPUTING THE NORM DOUBLE PRECISION KSUM2(*), MSUM2(*) * THE NORM OF K DOUBLE PRECISION KNORM2 * THE NORM OF M DOUBLE PRECISION MNORM2 * THE DIAGONAL OF THE STIFFNESS MATRIX DOUBLE PRECISION KDIAG(*) * THE STIFFNESS MATRIX DOUBLE PRECISION K(*), TK(*) * ROW AND COLUMN POINTERS INTEGER KRP(*), TKRP(*), KCP(*), TKCP(*) * THE DIAGONAL OF THE MASS MATRIX DOUBLE PRECISION MDIAG(*) * THE MASS MATRIX DOUBLE PRECISION M(*), TM(*) * ROW AND COLUMN POINTERS INTEGER MRP(*), TMRP(*), MCP(*), TMCP(*) * SOME INTERNAL VARIABLES * LOCK VARIABLES * TEMPORARY NORMS * COUNT VARIABLES INTEGER L,J * TEMPORARY VARIABLE * DOUBLE PRECISION RN INTEGER COLM * VECTOR VERSION * COMPUTE NORMS * DIAGONALS FIRST DO 10 J = 1, N KSUM2(J) = ABS(KDIAG(J)) MSUM2(J) = ABS(MDIAG(J)) 10 CONTINUE * COMPUTE M SUMS DO 20 J = 1, N DO 30 L = MRP(J), MRP(J+1)-1 COLM = MCP(L) MSUM2(COLM) = MSUM2(COLM) + ABS(M(L)) 30 CONTINUE DO 35 L = TMRP(J)+1, TMRP(J+1)-1 COLM = TMCP(L) MSUM2(COLM) = MSUM2(COLM) + ABS(TM(L)) 35 CONTINUE 20 CONTINUE * COMPUTE K SUMS DO 40 J = 1, N DO 50 L = KRP(J), KRP(J+1)-1 COLM = KCP(L) KSUM2(COLM) = KSUM2(COLM) + ABS(K(L)) 50 CONTINUE DO 55 L = TKRP(J)+1, TKRP(J+1)-1 COLM = TKCP(L) KSUM2(COLM) = KSUM2(COLM) + ABS(TK(L)) 55 CONTINUE 40 CONTINUE KNORM2 = 0.0D0 MNORM2 = 0.0D0 DO 100 J = 1, N KNORM2 = MAX(KSUM2(J),KNORM2) MNORM2 = MAX(MSUM2(J),MNORM2) 100 CONTINUE RETURN END * FIND THE NORM OF K AND M (FULL MATRICES) SUBROUTINE GTFNRM(N,KNORM2,MNORM2,K,M) * N IS THE ORDER OF THE MATRIX INTEGER N * THE NORM OF K DOUBLE PRECISION KNORM2 * THE NORM OF M DOUBLE PRECISION MNORM2 * THE STIFFNESS MATRIX DOUBLE PRECISION K(N,N) * THE MASS MATRIX DOUBLE PRECISION M(N,N) * SOME INTERNAL VARIABLES INTEGER I,J DOUBLE PRECISION TKNORM, TMNORM KNORM2 = 0.0D0 MNORM2 = 0.0D0 DO 10 I = 1, N TKNORM = 0.0D0 TMNORM = 0.0D0 DO 20 J = 1, N TKNORM = TKNORM + ABS(K(I,J)) TMNORM = TMNORM + ABS(M(I,J)) 20 CONTINUE KNORM2 = MAX(KNORM2,TKNORM) MNORM2 = MAX(MNORM2,TMNORM) 10 CONTINUE RETURN END C$FORTRAN LANCZS *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: LANCZS.MSC * * AUTHOR: MARK JONES * * PURPOSE: THE SHIFT-INVERTED LANCZOS ALGORITHM * *********************************************************************** SUBROUTINE LANCZS(N,LDI,IPARAM,RPARAM,THETA,BJ, C Y,Q,P,P0,ALPHA,BETA,TBETA,Z, C WORKV1,WORKV2,OTHETA,ONUMT, C OEIGNM,NUMT, C NEWGES,FA,FARP,FARL,FIWRKV,FRWRKV, C INTLST,SIGLST,INTIDX,KAUX, C KRP,KCP,MAUX,MRP,MCP, C ETA0,ETA1,TSTATE,OLDBJ,TAU0,TAU1) * N IS THE ORDER OF THE MATRIX * WE USE IT FOR DECLARATIONS INSTEAD ON IPARAM(1) DUE * TO COMPILER PROBLEMS INTEGER N * THE LEADING DIMENSION OF Y (IT IS PART OF IPARAM), BUT DUE TO * A COMPILER PROBLEM IS PUT HERE INTEGER LDI * IPARAM IS A SET OF INTEGER PARAMETERS FOR LANCZOS INTEGER IPARAM(*) * RPARAM IS A SET OF DOUBLE PRECISION PARAMETERS FOR LANCZOS DOUBLE PRECISION RPARAM(*) * THETA IS AN ARRAY OF EIGENVALUES DOUBLE PRECISION THETA(*) * BJ IS AN ARRAY OF ERROR BOUNDS ON EIGENVALUES DOUBLE PRECISION BJ(*) * Y IS THE ARRAY OF EIGENVECTORS DOUBLE PRECISION Y(LDI,*) * Q IS THE ARRAY OF LANCZOS VECTORS DOUBLE PRECISION Q(N,*) * P IS THE DIRECTION VECTOR AT STEPS J, J-1 DOUBLE PRECISION P(*), P0(*) * ALPHA AND BETA ARE THE ARRAYS OF THE TRIDIAGONAL MATRIX, T DOUBLE PRECISION ALPHA(*), BETA(*) * TBETA IS THE SQUARE OF BETA DOUBLE PRECISION TBETA(*) * THE EIGENVECTORS OF T DOUBLE PRECISION Z(*) * SCRATCH WORK FILES DOUBLE PRECISION WORKV1(*), WORKV2(*) * OTHETA IS AN ARRAY OF OLD EIGENVALUES DOUBLE PRECISION OTHETA(*) * ONUMT IS THE ARRAY INDICES FOR OLD EIGENVECTORS INTEGER ONUMT(*) * OLD NUMBER OF EIGEN PAIRS GIVEN TO US INTEGER OEIGNM * GIVES THE INDEX FOR EIGENVALUE I INTO THE Y VECTOR INTEGER NUMT(*) * THE INCOMING GUESS DOUBLE PRECISION NEWGES(*) * STORAGE FOR THE FACTORED MATRIX DOUBLE PRECISION FA(*) * FARP IS THE VECTOR OF ROW POINTERS FOR FA INTEGER FARP(*) * FARL IS THE VECTOR OF ROW LENGTHS FOR FA INTEGER FARL(*) * WORK VECTORS FOR FACTORIZATION DOUBLE PRECISION FRWRKV(N+1,3) INTEGER FIWRKV(N+1,2) * A LIST OF INERTIA CALCULATIONS INTEGER INTLST(*) * A LIST OF SIGMAS DOUBLE PRECISION SIGLST(*) * THE NUMBER OF SIGMAS AND INERTIA INTEGER INTIDX * THE STIFFNESS MATRIX DOUBLE PRECISION KAUX(*) * A VECTOR ASSOCIATED WITH KAUX INTEGER KRP(*) * A VECTOR ASSOCIATED WITH KAUX INTEGER KCP(*) * THE MASS MATRIX DOUBLE PRECISION MAUX(*) * A VECTOR ASSOCIATED WITH MAUX INTEGER MRP(*) * A VECTOR ASSOCIATED WITH MAUX INTEGER MCP(*) * USED TO COMPUTE THE PRO RECURRENCE DOUBLE PRECISION ETA0(*) * USED TO COMPUTE THE PRO RECURRENCE DOUBLE PRECISION ETA1(*) * IF WE ARE DOING BOUNDARIES, WHAT IS THE STATE? INTEGER TSTATE * THE ERROR BOUNDS OF THE OLD EIGENVALUES DOUBLE PRECISION OLDBJ(*) * THE EXTERNAL TAU RECURRENCE DOUBLE PRECISION TAU0(*), TAU1(*) * THE FOLLOWING VARIABLES ARE INTERNAL VARIABLES * THE STARTING VALUE FOR THE S.O. RECURRENCES DOUBLE PRECISION ORESET * USED FOR ORTHOGONALIZATION OF NEWGES LOGICAL TRORTH * USED FOR EXTENDED INTERNAL ORTHO DOUBLE PRECISION DALPHA, GAMMA * THE NORM OF R AFTER STEP D) DOUBLE PRECISION RNORM * NWFLAG IS A BOOLEAN INDICATING WHAT COMBINATION OF FACTORIZATION * FORWARD OR BACK SOLVE TO DO INTEGER NWFLAG * A TEMPORARY VARIABLE USED IN EIGENVALUE TRANSFORMATIONS DOUBLE PRECISION TVAL * THE CURRENT STEP EXECUTION TIME INTEGER CSTTIM * THE ESTIMATED STEP EXECUTION TIME INTEGER ESTTIM * THE PREVIOUS STEP EXECUTION TIME INTEGER OSTTIM * INITIALIZATION EXECUTION TIME INTEGER INTTIM * THE ESTIMATED NUMBER OF STEPS TO CONVERGENCE INTEGER ESTSTP * THE ESTIMATED TIME UNTIL CONVERGENCE INTEGER TIMFIN * A TEMPORARY VARIABLE USED AS AN INDEX INTO Y INTEGER YIN * ACCEPTED OR NOT ACCEPTED LOGICAL ACPTFL * LANMAX IS THE MAXIMUM NUMBER OF LANCZOS STEPS INTEGER LANMAX * J IS THE STEP NUMBER INTEGER J * COUNT VARIABLES INTEGER I * THE NUMBER OF CONVERGED EIGENVALUES INTEGER NUMCON * THE NORM OF THE T MATRIX DOUBLE PRECISION TNORM * SQRT(MACHINE EPSILON) DOUBLE PRECISION DEPS * GOOD FINISH LOGICAL GFIN * BAD FINISH LOGICAL BFIN * TEMPORARY VARIABLE USED IN THE EIGENVALUE CALCULATIONS DOUBLE PRECISION STEMP * TEMPORARY VARIABLE USED SEVERAL PLACES DOUBLE PRECISION RTEMP * HAVE WE CONVERGED TO THE RIGHT (LEFT)? LOGICAL CLEFT, CRIGHT * HAVE WE SEEN AN UNCONVERGED TO THE RIGHT (LEFT)? LOGICAL UNCLEF, UNCRIG * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION SINPRD, SORTHO, RELERR, C EIGTRA, MRELER * INTEGER FUNCTIONS INTEGER GETIND, GBOUND, LOCALT, LOCAL2 EXTERNAL SINPRD, SORTHO, RELERR, EIGTRA, MRELER EXTERNAL GETIND, GBOUND, LOCALT EXTERNAL VECDSC, CMPVEC, LOCAL2, L2TMOF, L2TMON EXTERNAL TQL2, MATEYE, PREDCT, EIGCLC, CPYVEC, VECSAX EXTERNAL APPINP, LTIMON, BOPER, LTIMOF, PURGE * PRINT A LISTING OF THE PARAMETERS IF ((IPARAM(9).EQ.0).AND.(TSTATE.EQ.5).AND.(RPARAM(5).LE.0.0D0) C .AND.(IPARAM(19).EQ.0)) THEN IPARAM(6) = 0 IPARAM(4) = 0 RETURN ENDIF * SET VARIABLES TO THE CORRECT PARAMETERS LANMAX = IPARAM(4) DEPS = SQRT(RPARAM(2)) IF (N.LE.0) RETURN * INITIALIZATION STEP * COMPUTE M*NEWGES CALL APPINP(N,WORKV1,NEWGES,IPARAM(9), C IPARAM(17),MAUX,MRP,MCP,IPARAM(15),KAUX,KRP,KCP) * FIRST, ORTHOGONALIZE NEWGES AGAINST ANY PREVIOUS EIGENVECTORS TRORTH = .TRUE. DO 1 I = 1, OEIGNM RTEMP = SORTHO(N,NEWGES,WORKV1,Y(1,ONUMT(I)), C Y(1,ONUMT(I)),DEPS,TRORTH) 1 CONTINUE * RESTRICT THE GUESS TO RANGE OF THE PENCIL CALL LTIMON() NWFLAG = 0 CALL APPINP(N,WORKV1,NEWGES,IPARAM(9), C IPARAM(17),MAUX,MRP,MCP,IPARAM(15),KAUX,KRP,KCP) CALL BOPER(N,WORKV1,Q(1,1),RPARAM(1),IPARAM(9),NWFLAG, C IPARAM(24),IPARAM(11),FA,FARP,FARL,FIWRKV,FRWRKV,INTLST, C SIGLST,INTIDX,IPARAM(8),IPARAM(18),IPARAM(25), C IPARAM(26),IPARAM(23),IPARAM(12),IPARAM(15),KAUX,KRP,KCP, C IPARAM(17),MAUX,MRP,MCP,RPARAM(7),IPARAM(20),IPARAM(21), C IPARAM(22),IPARAM(28)) IF ((TSTATE.EQ.4).OR.(TSTATE.EQ.5)) THEN IPARAM(3) = GBOUND(INTIDX,SIGLST,INTLST,RPARAM(5),RPARAM(6), C TSTATE) TVAL = (RPARAM(5)+RPARAM(6))/2.0D0 DO 3 I = 1, OEIGNM IF (TSTATE.EQ.4) THEN IF ((OTHETA(I).GE.TVAL).AND.(OTHETA(I).LE.RPARAM(6))) C THEN IPARAM(3) = IPARAM(3) - 1 ENDIF ELSE IF ((OTHETA(I).LE.TVAL).AND.(OTHETA(I).GE.RPARAM(5))) C THEN IPARAM(3) = IPARAM(3) - 1 ENDIF ENDIF 3 CONTINUE ENDIF IF ((TSTATE.EQ.4).OR.(TSTATE.EQ.5)) THEN IF (IPARAM(3).EQ.0) THEN IPARAM(6) = 0 IPARAM(4) = 0 RETURN ENDIF ENDIF * CALCULATE THE INITIAL RESIDUAL AND BETA(1) CALL APPINP(N,P,Q(1,1),IPARAM(9), C IPARAM(17),MAUX,MRP,MCP,IPARAM(15),KAUX,KRP,KCP) * AT THIS POINT, WE KNOW THAT WHATEVER FACTORIZATION IS * GOING TO TAKE PLACE, HAS TAKEN PLACE NWFLAG = 1 BETA(1) = SQRT(SINPRD(N,P,Q(1,1))) CALL LTIMOF() INTTIM = LOCALT() * MORE INITIALIZATION NUMCON = 0 TNORM = 0.0D0 CSTTIM = 1.0D0 ESTTIM = 1.0D0 IF (((IPARAM(9).EQ.0).AND.(TSTATE.EQ.1).AND.(RPARAM(5).LE.0.0D0)) C .OR.((IPARAM(9).EQ.0).AND.(INTLST(INTIDX).LE.0.0D0))) THEN CLEFT = .TRUE. ELSE CLEFT = .FALSE. ENDIF CRIGHT = .FALSE. RTEMP = N ORESET = 0.5*SQRT(RTEMP)*RPARAM(2) * STEP 0) IF NECESSARY, RE-ORTHOGONALIZE R(J-1) AND Q(J-1) * AGAINST A PREVIOUSLY COMPUTED RITZ VECTOR CALL PURGE(N,0,Q,P,P0,ALPHA,BETA, C TBETA(1),BJ,OEIGNM, C OTHETA,OLDBJ,LDI,Y,ONUMT,ETA0,ETA1,TAU0,TAU1, C RNORM,THETA,KAUX,KRP,KCP,MAUX,MRP,MCP,IPARAM(9),IPARAM(15), C IPARAM(17),IPARAM(8),RPARAM(1),DEPS,ORESET,WORKV1,WORKV2) * MAIN LOOP * LOOP UNTIL CONVERGENCE OF REQUIRED NUMBER OF EIGENVALUES * OR UNTIL WE HAVE DETECTED ALL EIGENVALUES IN AN INTRVL * OR WE EXCEED THE MAXIMUM NUMBER OF ITERATIONS DO 100 J = 1, LANMAX OSTTIM = CSTTIM CALL LTIMON() * STEP B) Q(J) = R(J-1)/BETA(J) * STEP C) P(J) = P(J)/BETA(J) * THESE TWO OPERATIONS ARE DONE IN THE PURGE STEP * STEP D) SOLVE (PENCIL)*R(J)=P(J) FOR R(J) CALL BOPER(N,P,Q(1,J+1),RPARAM(1),IPARAM(9),NWFLAG, C IPARAM(24),IPARAM(11),FA,FARP,FARL,FIWRKV,FRWRKV,INTLST, C SIGLST,INTIDX,IPARAM(8),IPARAM(18),IPARAM(25), C IPARAM(26),IPARAM(23),IPARAM(12),IPARAM(15),KAUX,KRP,KCP, C IPARAM(17),MAUX,MRP,MCP,RPARAM(7),IPARAM(20),IPARAM(21), C IPARAM(22),IPARAM(28)) IF (OEIGNM.GT.0) THEN RNORM = SQRT(SINPRD(N,Q(1,J+1),Q(1,J+1))) ENDIF * STEP E) COPY Q(J-1) OUT TO SECONDARY STORE * SINCE WE AREN'T USING SECONDARY STORE, WE DON'T DO * THIS * STEP F) R(J) = R(J) - Q(J-1)*BETA * THIS STEP HAS BEEN EXPANDED TO PERFORM EXTENDED LOCAL * ORTHOGONALIZATION IF (J.NE.1) THEN GAMMA = SINPRD(N,P0,Q(1,J+1)) CALL VECSAX(N,Q(1,J+1),Q(1,J-1),-GAMMA) DALPHA = SINPRD(N,Q(1,J+1),P) CALL VECSAX(N,Q(1,J+1),Q(1,J),-DALPHA) GAMMA = SINPRD(N,P0,Q(1,J+1)) CALL VECSAX(N,Q(1,J+1),Q(1,J-1),-GAMMA) ELSE DALPHA = SINPRD(N,Q(1,J+1),P) CALL VECSAX(N,Q(1,J+1),Q(1,J),-DALPHA) END IF * STEP G) COPY OLD P CALL CPYVEC(N,P0,P) * STEP H) ALPHA(J) = R(J)*P(J) ALPHA(J) = SINPRD(N,Q(1,J+1),P) * STEP I) R(J) = R(J) - Q(J)*ALPHA(J) CALL VECSAX(N,Q(1,J+1),Q(1,J),-ALPHA(J)) * STEP J) FORM P(J+1) = M*R(J) CALL APPINP(N,P,Q(1,J+1),IPARAM(9), C IPARAM(17),MAUX,MRP,MCP,IPARAM(15),KAUX,KRP,KCP) * STEP K) BETA(J+1) = SQRT(R(J)*P(J+1)) * PUT BETA INTO TBETA TBETA(J+1) = SINPRD(N,Q(1,J+1),P) BETA(J+1) = SQRT(TBETA(J+1)) * UPDATE ALPHA (WE DO IT HERE TO AVOID CLUTTERING UP THE * PRIOR BARRIER ALPHA(J) = ALPHA(J) + DALPHA * STEP L) UPDATE EIGENVALUES OF T(J) AND THEIR ERROR BOUNDS * AND THEN CHECK FOR CONVERGENCE. * FIRST, FIND THE FROBENIOUS NORM OF T IF (J.EQ.1) THEN TNORM = ALPHA(1) ELSE TNORM = SQRT(TNORM*TNORM+ALPHA(J)*ALPHA(J)+ C 2*BETA(J)*BETA(J)) ENDIF * THE DEBUG PARAMETER FOR EIGCLC IS TEMPORARILY SET TO 0 * THIS ROUTINE LOCATES THE EIGENVALUES AND ERROR BOUNDS * OF T CALL EIGCLC(J,ALPHA,TBETA,THETA,BJ, C WORKV2,TNORM,RPARAM(2),0,RPARAM(4),WORKV1,Z) * INITIALIZATION FOR THE NEXT LOOP NUMCON = 0 UNCLEF = .FALSE. UNCRIG = .FALSE. * CHECK TO SEE WHETHER EIGENVALUES HAVE CONVERGED DO 200 I = 1, J IF (RELERR(THETA(I),BJ(I),RPARAM(1),IPARAM(9)).LT. C RPARAM(3)) THEN IF (TSTATE.EQ.4) THEN TVAL = EIGTRA(THETA(I),RPARAM(1),IPARAM(9)) IF ((TVAL.GE.((RPARAM(5)+RPARAM(6))/2.0D0)).AND. C (TVAL.LE.RPARAM(6))) THEN NUMCON = NUMCON + 1 ENDIF ELSE IF (TSTATE.EQ.5) THEN TVAL = EIGTRA(THETA(I),RPARAM(1),IPARAM(9)) IF ((TVAL.LE.((RPARAM(5)+RPARAM(6))/2.0D0)).AND. C (TVAL.GE.RPARAM(5))) THEN NUMCON = NUMCON + 1 ENDIF ELSE IF (TSTATE.GE.1) THEN TVAL = EIGTRA(THETA(I),RPARAM(1),IPARAM(9)) IF (TVAL.GE.RPARAM(6)) THEN CRIGHT = .TRUE. ELSE IF (TVAL.LE.RPARAM(5)) THEN CLEFT = .TRUE. ELSE IF ((TVAL.GE.RPARAM(5)).AND. C (TVAL.LE.RPARAM(6))) THEN NUMCON = NUMCON + 1 ENDIF ELSE NUMCON = NUMCON + 1 ENDIF ELSE TVAL = EIGTRA(THETA(I),RPARAM(1),IPARAM(9)) IF (TVAL.LT.RPARAM(1)) THEN UNCLEF = .TRUE. ELSE UNCRIG = .TRUE. ENDIF ENDIF 200 CONTINUE * DON'T BOTHER IF BETA IS 0 IF (BETA(J+1).NE.0.0D0) THEN * STEP ?) IF NECESSARY, RE-ORTHOGONALIZE R(J) AND Q(J) * AGAINST PREVIOUS LANCZOS VECTORS OR OLD EIGENPAIRS CALL PURGE(N,J,Q,P,P0,ALPHA,BETA, C TBETA(J+1),BJ,OEIGNM, C OTHETA,OLDBJ,LDI,Y,ONUMT,ETA0,ETA1,TAU0,TAU1, C RNORM,THETA,KAUX,KRP,KCP,MAUX,MRP,MCP,IPARAM(9),IPARAM(15), C IPARAM(17),IPARAM(8),RPARAM(1),DEPS,ORESET,WORKV1,WORKV2) ENDIF * DETERMINE WHETHER WE ARE FINISHED BFIN = .FALSE. GFIN = .FALSE. IF (((NUMCON.GE.IPARAM(3)).AND.((TSTATE.EQ.0).OR. C (TSTATE.GE.4))).OR. C (CRIGHT.AND.CLEFT.AND.(TSTATE.EQ.1)).OR. C (CRIGHT.AND.(.NOT.UNCLEF).AND.(TSTATE.EQ.1)).OR. C (CLEFT.AND.(.NOT.UNCRIG).AND.(TSTATE.EQ.1)).OR. C (CRIGHT.AND.(TSTATE.EQ.2)).OR.(CLEFT.AND.(TSTATE.EQ.3))) THEN GFIN = .TRUE. ENDIF IF ((J.GE.10).AND.(.NOT.GFIN).AND.(IPARAM(27).NE.1).AND. C (MOD(J,2).EQ.1)) THEN CALL PREDCT(J,N,THETA,BJ,IPARAM(8),RPARAM(3), C RPARAM(1),RPARAM(2),RPARAM(4),IPARAM(9),ESTSTP,IPARAM(13)+30,Z, C Z(1+(IPARAM(13)+30)*(IPARAM(13)+29)), C Z(1+(IPARAM(13)+30)*(IPARAM(13)+28)), C Z(1+(IPARAM(13)+30)*(IPARAM(13)+27)), C Z(1+(IPARAM(13)+30)*(IPARAM(13)+26)), C Z(1+(IPARAM(13)+30)*(IPARAM(13)+25))) IF ((ESTSTP.GT.100).OR.(ESTSTP+J.GT.LANMAX)) THEN BFIN = .TRUE. ENDIF TIMFIN = ((ESTTIM+OSTTIM)/2.0D0)*ESTSTP * WHAT ABOUT THE COST OF EARLY STEPS VS. LATE STEPS? IF ((IPARAM(24).EQ.0).AND.((IPARAM(9).EQ.2).OR. C ((IPARAM(9).EQ.0).AND.(RPARAM(1).LE.0.0D0)))) THEN IF (TIMFIN.GT.INTTIM*1.5) THEN BFIN = .TRUE. ENDIF ELSE IF (TIMFIN.GT.INTTIM) THEN BFIN = .TRUE. ENDIF ENDIF ENDIF IF ((J.EQ.LANMAX).AND.(.NOT.GFIN)) THEN BFIN = .TRUE. ENDIF IF ((ABS(BETA(J+1)/ALPHA(J)).LE.(SQRT(RPARAM(2)))).AND. C (.NOT.GFIN)) THEN PRINT *,'WARNING: IT APPEARS THAT EITHER FEWER THAN N' PRINT *,'EIGENVALUES EXIST AND THAT ALL OF THEM' PRINT *,'HAVE BEEN FOUND OR THAT ALL REMAINING EIGENVALUES' PRINT *,'HAVE EIGENVECTORS THAT ARE ORTHOGONAL TO THE' PRINT *,'LANCZOS VECTORS. THIS IS SIGNALLED BY A' PRINT *,'VERY SMALL BETA(J+1).' PRINT *,'LANZ WILL NOT SEARCH FURTHER' GFIN = .TRUE. ENDIF CALL LTIMOF() CSTTIM = LOCALT() IF (OSTTIM.EQ.0) THEN OSTTIM = (CSTTIM/2)+1 ESTTIM = (CSTTIM*2)+1 ELSE IF ((FLOAT(CSTTIM)/FLOAT(OSTTIM)).GT.2.0D0) THEN ESTTIM = 2*CSTTIM ELSE ESTTIM = (FLOAT(CSTTIM)/FLOAT(OSTTIM))*CSTTIM ENDIF ENDIF IF (GFIN) GOTO 105 IF (BFIN) GOTO 110 100 CONTINUE IPARAM(6) = -1 GOTO 110 105 CONTINUE IPARAM(6) = 0 110 CONTINUE IF (J.GT.LANMAX) J = LANMAX * COMPUTE THE EIGENVECTORS AND EIGENVALUES OF T VIA QL DO 401 I = 1, J NUMT(I) = 0 401 CONTINUE CALL MATEYE(J,J,Z) CALL CPYVEC(J,THETA,ALPHA) CALL CPYVEC(J,TBETA,BETA) IF (IPARAM(8).GE.2) THEN CALL L2TMON() ENDIF CALL TQL2(J,J,THETA,TBETA,Z,IERR) IF (IPARAM(8).GE.2) THEN PRINT *,'RETURN FROM TQL IS ',IERR CALL L2TMOF() PRINT *,'TQL2 TOOK ',LOCAL2() ENDIF * NOW COMPUTE THE CONVERGED EIGENVECTORS DO 410 I = 1, J BJ(I) = MAX(ABS(BETA(J+1)*Z(J+(I-1)*J)),ABS(THETA(I)* C RPARAM(2))) IF (RELERR(THETA(I),BJ(I),RPARAM(1),IPARAM(9)).LE. C RPARAM(3)) THEN YIN = GETIND(IPARAM(2),J,NUMT,ONUMT,WORKV1) NUMT(I) = YIN IF (IPARAM(8).GE.2) THEN PRINT *,'COMPUTING ',I,YIN,THETA(I) PRINT *,'EST ERROR IS ',RELERR(THETA(I),BJ(I), C RPARAM(1),IPARAM(9)) ENDIF ENDIF IF (NUMT(I).GT.0) THEN CALL CPYVEC(J,WORKV2,Z(1+(I-1)*J)) CALL CMPVEC(N,Q,J,WORKV2,ALPHA,BETA, C THETA(I),Y(1,YIN),IPARAM(9)) CALL APPINP(N,WORKV1,Y(1,YIN),IPARAM(9), C IPARAM(17),MAUX,MRP,MCP,IPARAM(15),KAUX,KRP,KCP) STEMP = SQRT(SINPRD(N,Y(1,YIN),WORKV1)) CALL VECDSC(N,Y(1,YIN),Y(1,YIN),STEMP) ENDIF 410 CONTINUE * TRANSFORM THETAS INTO LAMBDAS DO 400 I = 1, J IF (RELERR(THETA(I),BJ(I),RPARAM(1),IPARAM(9)).GE. C RPARAM(3)) THEN ACPTFL = .FALSE. ELSE ACPTFL = .TRUE. ENDIF BJ(I) = RELERR(THETA(I),BJ(I),RPARAM(1),IPARAM(9)) THETA(I) = EIGTRA(THETA(I),RPARAM(1),IPARAM(9)) IF (.NOT.ACPTFL) THEN BJ(I) = -BJ(I) ENDIF 400 CONTINUE IPARAM(4) = J IPARAM(7) = NUMCON IF ((J.EQ.LANMAX).AND.(.NOT.GFIN)) THEN PRINT *,'WARNING: RAN OUT OF STORAGE' PRINT *,'FIXED: RESTARTED LANCZOS TO REUSE STORAGE' PRINT *,'REMEDY: FOR BETTER EFFICIENCY, INCREASE MXLI' ENDIF RETURN END C$FORTRAN LANZ *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: LANZ.MSC * * AUTHOR: MARK JONES * * PURPOSE: THE MAIN SUBROUTINE FOR THE LANZ ALGORITHM * *********************************************************************** SUBROUTINE LANZ(LDI,INPARI,INPARR,OTHETA,OLDBJ,Y,ONUMT,KAUX,KRP, C KCP,MAUX,MRP,MCP,R1Y) * THE LEADING INDEX OF Y INTEGER LDI * INPARI IS A SET OF INTEGER PARAMETERS FROM THE CALLING ROUTINE * 1 = THE ORDER OF THE MATRIX * 2 = THE MAXIMUM NUMBER OF EIGENVALUES THAT CAN BE STORED * 3 = THE NUMBER OF EIGENVALUES BEING SOUGHT * 4 = (ON INPUT) THE MAXIMUM NUMBER OF LANCZOS STEPS TO TAKE * (ON OUTPUT) THE NUMBER OF LANCZOS STEPS TAKEN * 5 = THE RETURN VALUE OF LANCZOS (0 MEANS NO ERROR) * 6 = (ON INPUT) THE NUMBER OF EIGENVALUES ALREADY FOUND * (ON OUTPUT) THE NUMBER OF EIGENVALUES CORRECTLY FOUND * 7 = THE LEVEL OF DEBUGGING OUTPUT * 8 = VIBRATION (0) OR BUCKLING (1 W/ SHIFT) (2 W/O SHIFT) * 9 = INERTIA CHECKING (0=NONE, 1=YES) * 10 = AMOUNT OF OUTPUT * 11 = THE MAX. NUMBER OF STEPS ON ONE SHIFT * 12 = TYPE OF EIGENPROBLEM (0=CLOSEST TO SIGMA * 1=SEARCH IN RANGE) * 13 = STORAGE FORMAT FOR K (0=SPARSE,1=FULL) (DON'T USE FULL) * 14 = STORAGE FORMAT FOR M (0=SPARSE,1=FULL) (DON'T USE FULL) * 15 = LEVEL OF LOOP UNROLLING (1,4, OR 6, APPLIES ON TO POSITIVE * DEFINITE SOLVER, THE LEVEL OF * UNROLLING FOR THE INDEFINITE * SOLVER IS SET IN THE MAKEFILE) * 16 = THE TYPE OF FACTORIZATION (0 = BUNCH-KAUFMAN IF INDEFINITE * LDL IF P.D. * 1 = ALWAYS USE LDL * 2 = SAME AS 0 BUT SPARSE * 3 = SAME AS 1 BUT SPARSE) * 17 = DYNAMIC SHIFTING TURNED OFF (0=ON, 1=OFF) * 18 = INITIAL GUESS (1), NO GUESS (0) * 19 = THE LEADING INDEX OF THE ARRAY Y * 20 = THE NUMBER OF DELAYED PIVOTS TO ALLOW SPACE FOR INTEGER INPARI(*) * INPARR IS A SET OF FLOAT PARAMETERS FROM THE CALLING ROUTINE * 1 = THE SIGMA TO BE SEARCHED AROUND * 2 = THE REQUIRED RELATIVE ACCURACY OF THE EIGENVALUES * 3 = LEFT SIDE OF BOUNDARY TO SEARCH (IF ANY) * 4 = RIGHT SIDE OF BOUNDARY TO SEARCH (IF ANY) * 5 = THE STORAGE FACTOR FOR BUNCH-KAUFMAN DOUBLE PRECISION INPARR(*) * OLDTHETA IS AN ARRAY OF CONVERGED EIGENVALUES DOUBLE PRECISION OTHETA(*) * OLDBJ IS AN ARRAY OF ERROR BOUNDS ON CONVERGED EIGENVALUES DOUBLE PRECISION OLDBJ(*) * Y IS THE ARRAY OF EIGENVECTORS USED IN A LANCZOS RUN DOUBLE PRECISION Y(LDI,*) * ONUMT IS A WORK VECTOR FOR MSHIFT INTEGER ONUMT(*) * KAUX IS THE STIFFNESS MATRIX DOUBLE PRECISION KAUX(*) * KRP IS AN AUXILARY INTEGER VECTOR USED WHEN USING KAUX INTEGER KRP(*) * KCP IS AN AUXILARY INTEGER VECTOR USED WHEN USING KAUX INTEGER KCP(*) * MAUX IS THE MASS MATRIX DOUBLE PRECISION MAUX(*) * MRP IS AN AUXILARY INTEGER VECTOR USED WHEN USING MAUX INTEGER MRP(*) * MCP IS AN AUXILARY INTEGER VECTOR USED WHEN USING MAUX INTEGER MCP(*) * INITIAL GUESS VECTOR DOUBLE PRECISION R1Y(*) * INTERNAL VARIABLES * FA IS A MATRIX TO BE USED FOR FACTORIZATION DOUBLE PRECISION FA(1) * FARP IS THE VECTOR OF ROW POINTERS FOR FA INTEGER FARP(1) * FARL IS THE VECTOR OF ROW LENGTHS FOR FA INTEGER FARL(1) * THESE ARE THE EIGENVALUES FOR LANCZOS RUNS DOUBLE PRECISION R1THET(1),R2THET(1) * BJ IS AN ARRAY OF ERROR BOUNDS ON EIGENVALUES DOUBLE PRECISION R1BJ(1), R2BJ(1) * INTLST IS AN ARRAY OF INERTIA CALCULATIONS INTEGER INTLST(1) * SIGLST IS AN ARRAY OF SIGMAS DOUBLE PRECISION SIGLST(1) * THE NUMBER OF INERTIAS AND SIGMAS INTEGER INTIDX * OLD NUMBER OF EIGEN PAIRS INTEGER OEIGNM * THIS IS A WORK VECTOR FOR LANCZOS INTEGER NUMT(1) * THIS IS A WORK VECTOR FOR LANCZOS DOUBLE PRECISION ETA0(1), ETA1(1) * THIS IS A WORK VECTOR FOR LANCZOS DOUBLE PRECISION TAU0(1), TAU1(1) * WORKY IS A WORK ARRAY FOR LANCZOS (THE Q VECTORS) DOUBLE PRECISION WORKY(1) * SPACE FOR COMPUTING THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX * ALSO USED AS WORKSPACE, HENCE THE ADDITIONAL SIZE DOUBLE PRECISION Z(1) * P IS THE DIRECTION VECTOR FOR LANCZOS AT STEP J, J-1 DOUBLE PRECISION P(1), P0(1) * ALPHA AND BETA ARE THE ARRAY OF THE TRIDIAGONAL MATRIX, T DOUBLE PRECISION ALPHA(1), BETA(1) * TBETA IS THE SQUARE OF BETA DOUBLE PRECISION TBETA(1) * WORK VECTORS FOR MATRIX SOLUTION DOUBLE PRECISION FRWRKV(1) INTEGER FIWRKV(1) * WORK VECTORS FOR LANCZOS DOUBLE PRECISION WORKV1(1),WORKV2(1) * IPARAM IS A SET OF INTEGER PARAMETERS FOR LANCZOS * 1 = THE ORDER OF THE MATRIX * 2 = THE MAXIMUM NUMBER OF EIGENVALUES THAT CAN BE STORED * 3 = THE NUMBER OF EIGENVALUES BEING SOUGHT * 4 = THE MAXIMUM NUMBER OF LANCZOS STEPS TO TAKE * 5 = INERTIA CHECKING? * 6 = THE RETURN VALUE OF LANCZOS * .EQ.0 THEN NO ERROR * 7 = THE NUMBER OF EIGENVALUES CORRECTLY FOUND * 8 = THE LEVEL OF DEBUGGING OUTPUT * 9 = VIBRATION (0) OR BUCKLING (1 W/ SHIFT) (2 W/O SHIFT) * 10 = ERROR CHECKING LEVEL * 11 = THE OFFSET ADDRESS OF THE FACTORIZATION SPACE * 12 = MEMORY ALLOCATED * 13 = THE MAX. NUMBER OF STEPS ON ONE SHIFT * 14 = TYPE OF EIGENPROBLEM * 15 = STORAGE FORMAT FOR K (0=SPARSE,1=FULL) * 16 = THE LEADING INDEX OF THE ARRAY Y * 17 = STORAGE FORMAT FOR M (0=SPARSE,1=FULL) * 18 = LEVEL OF LOOP UNROLLING * 19 = 1 IF K IS SPD (SET IN MSHIFT IF 9 IS 3) * 20 = THE MAXIMUM NUMBER OF DELAYED PIVOTS THAT CAN BE STORED * 21 = SIZE OF INDICES ALLOCATED FOR SPARSE FACTORIZATION * 22 = THE OFFSET ADDRESS OF INDICES FOR SPARSE FACTORIZATION * 23 = THE ACTUAL ADDRESS OF THE FACTORIZATION WORK SPACE * 24 = THE TYPE OF FACTORIZATION (0 = BK OR CHOL, 1 = ONLY CHOL) * 2 = SAME AS 0 BUT SPARSE, 3 = SAME AS 1 BUT SPARSE * 25 = A POINTER INDICATING WHETHER SPACE FOR B-K FACTORIZATION * HAS BEEN CALCULATED AND ALLOCATED * 26 = SIZE OF THE FACTORIZATION ARRAY * 27 = DYNAMIC SHIFTING TURNED OFF (1) * 28 = THE ACTUAL ADDRESS OF INDICES ALLOCATED FOR SPARSE * FACTORIZATION * 29 = 0-NO INITIAL GUESS, 1-INITIAL GUESS IS IN R1Y INTEGER IPARAM(29) * RPARAM IS A SET OF DOUBLE PRECISION PARAMETERS FOR LANCZOS * 1 = THE SIGMA TO BE SEARCHED AROUND * 2 = THE MACHINE EPSILON * 3 = THE REQUIRED ACCURACY OF THE EIGENVALUES * 4 = THE LARGEST DOUBLE PRECISION NUMBER POSSIBLE * 5 = LEFT SIDE OF BOUNDARY * 6 = RIGHT SIDE OF BOUNDARY * 7 = THE STORAGE FACTOR FOR BUNCH-KAUFMAN DOUBLE PRECISION RPARAM(7) * INTERNAL VARIABLES * ADDRESS VARIABLES INTEGER LIST(34) INTEGER ALIST(34) * AN INDEX VARIABLE FOR LOOPS INTEGER I, J, K * TOTAL AMOUNT OF MEMORY ALLOCATED INTEGER TMEM * RETURN VALUE FROM PREP (0=OKAY) INTEGER OKPREP * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION SINPRD * INTEGER FUNCTIONS INTEGER PREP EXTERNAL PREP * SET UP THE PARAMETERS AND * RECONCILE THE INPUT PARAMETERS WITH THE LANZ PARAMETERS OKPREP = PREP(IPARAM,RPARAM,INPARI,INPARR) IF (OKPREP.NE.0) GOTO 100 TMEM = 0 IPARAM(11) = 0 IPARAM(21) = 0 IPARAM(26) = 0 * MANY OF THE WORK VARIABLES ARE ALLOCATED HERE CALL FALLOC(IPARAM(13),0,R1THET,TMEM,LIST(1),ALIST(1)) CALL FALLOC(IPARAM(13),0,R2THET,TMEM,LIST(2),ALIST(2)) CALL FALLOC(IPARAM(13),0,R1BJ,TMEM,LIST(3),ALIST(3)) CALL FALLOC(IPARAM(13),0,R2BJ,TMEM,LIST(4),ALIST(4)) CALL FALLOC(IPARAM(2),1,INTLST,TMEM,LIST(5),ALIST(5)) CALL FALLOC(IPARAM(2),0,SIGLST,TMEM,LIST(6),ALIST(6)) CALL FALLOC(IPARAM(2),0,ETA0,TMEM,LIST(8),ALIST(8)) CALL FALLOC(IPARAM(2),0,ETA1,TMEM,LIST(9),ALIST(9)) CALL FALLOC(IPARAM(13),1,NUMT,TMEM,LIST(10),ALIST(10)) CALL FALLOC((IPARAM(13)+30)*(IPARAM(13)+30),0,Z,TMEM, C LIST(13),ALIST(13)) CALL FALLOC(IPARAM(1)*(IPARAM(13)+1),0,WORKY,TMEM,LIST(16), C ALIST(16)) CALL FALLOC(IPARAM(1),0,P,TMEM,LIST(17),ALIST(17)) CALL FALLOC(IPARAM(1),0,P0,TMEM,LIST(18),ALIST(18)) CALL FALLOC((IPARAM(1)+1)*12,0,FRWRKV,TMEM,LIST(21),ALIST(21)) CALL FALLOC((IPARAM(1)+1)*2,1,FIWRKV,TMEM,LIST(22),ALIST(22)) CALL FALLOC(IPARAM(13),0,ALPHA,TMEM,LIST(23),ALIST(23)) CALL FALLOC(IPARAM(13)+1,0,BETA,TMEM,LIST(24),ALIST(24)) CALL FALLOC(IPARAM(1),0,WORKV1,TMEM,LIST(26),ALIST(26)) CALL FALLOC(IPARAM(1),0,WORKV2,TMEM,LIST(27),ALIST(27)) CALL FALLOC(IPARAM(13)+1,0,TBETA,TMEM,LIST(28),ALIST(28)) CALL FALLOC(IPARAM(1)+1,1,FARP,TMEM,LIST(29),ALIST(29)) CALL FALLOC(IPARAM(1)+1,1,FARL,TMEM,LIST(30),ALIST(30)) CALL FALLOC(IPARAM(2),0,TAU0,TMEM,LIST(33),ALIST(33)) CALL FALLOC(IPARAM(2),0,TAU1,TMEM,LIST(34),ALIST(34)) IF (IPARAM(10).GT.0) THEN PRINT *,'LANZ ALLOCATED ',TMEM,' BYTES (NOT INCLUDING ', C 'FACTORIZATION SPACE)' ENDIF IPARAM(12) = TMEM IPARAM(25) = 0 OEIGNM = IPARAM(7) * IF A BAD RETURN VALUE FROM PREP THEN RETURN 100 CONTINUE IF (OKPREP.NE.0) THEN INPARI(5) = -1 RETURN ENDIF * START WORKING CALL MSHIFT(IPARAM(1),IPARAM(16),IPARAM,RPARAM, C R1THET(LIST(1)),R1BJ(LIST(3)), C R2THET(LIST(2)),R2BJ(LIST(4)),Y,R1Y, C WORKY(LIST(16)),P(LIST(17)),P0(LIST(18)), C ALPHA(LIST(23)),BETA(LIST(24)), C TBETA(LIST(28)),Z(LIST(13)), C WORKV1(LIST(26)),WORKV2(LIST(27)),OTHETA, C ONUMT,OEIGNM,OLDBJ, C NUMT(LIST(10)), C INTLST(LIST(5)),SIGLST(LIST(6)),INTIDX, C FA,FARP(LIST(29)),FARL(LIST(30)),FIWRKV(LIST(22)), C FRWRKV(LIST(21)), C KAUX,KRP,KCP,MAUX,MRP,MCP, C ETA0(LIST(8)),ETA1(LIST(9)), C TAU0(LIST(33)),TAU1(LIST(34))) * ERROR CHECKING ROUTINES * SORT THE EIGENVALUES SO THAT WE CAN PRINT THEM OUT IN * ASCENDING ORDER CALL BSORT3(OEIGNM,OTHETA,ONUMT,OLDBJ) * ERROR TESTS AND PRINTING AT THE OPTION OF THE USER IF ((MOD(IPARAM(10),128)/64.GE.1).OR.(IPARAM(6).EQ.-2)) THEN * JUST PRINT THE EIGENVALUES PRINT 604 DO 800 I = 1, OEIGNM PRINT 610,I,OTHETA(I) 800 CONTINUE ENDIF IF (MOD(IPARAM(10),64)/32.GE.1) THEN * JUST PRINT THE EIGENVALUES AND THE ESTIMATED ERROR PRINT 602 DO 810 I = 1, OEIGNM PRINT 615,I,OTHETA(I),OLDBJ(I) 810 CONTINUE ENDIF IF (IPARAM(6).EQ.-2) THEN GOTO 1001 ENDIF IF (MOD(IPARAM(10),32)/16.GE.1) THEN * DO A TEST FOR DOUBLE PRECISION RELATIVE ERROR AND PRINT PRINT 600 DO 820 I = 1, OEIGNM IF (IPARAM(9).EQ.0) THEN CALL VECXSC(IPARAM(1),WORKV2(LIST(27)),Y(1,ONUMT(I)), C OTHETA(I)) ELSE CALL VECXSC(IPARAM(1),WORKV2(LIST(27)),Y(1,ONUMT(I)), C -OTHETA(I)) ENDIF CALL MAPPLY(IPARAM(1),WORKV1(LIST(26)), C WORKV2(LIST(27)),IPARAM(17),MAUX,MRP,MCP) * P IS USED AS A WORK VECTOR FROM HERE DOWN CALL KAPPLY(IPARAM(1),P(LIST(17)),Y(1,ONUMT(I)), C IPARAM(15),KAUX,KRP,KCP) CALL VECSUB(IPARAM(1),P(LIST(17)),P(LIST(17)), C WORKV1(LIST(26))) PRINT 605,I,OTHETA(I),OLDBJ(I), C SQRT(SINPRD(IPARAM(1),P(LIST(17)),P(LIST(17))))/ C ABS(OTHETA(I)) IF (MOD(IPARAM(10),256)/128.GE.1) THEN PRINT 630,SQRT(ABS(OTHETA(I)))/1000.0D0 ENDIF 820 CONTINUE ENDIF IF (MOD(IPARAM(10),8)/4.GE.1) THEN * PRINT ALL INERTIA CALCULATIONS TO DATE CALL BSORT2(INTIDX,SIGLST(LIST(6)),INTLST(LIST(5))) PRINT *,'INERTIA LISTING' DO 860 I = 1, INTIDX IF (IPARAM(9).EQ.0) THEN PRINT *,'INERTIA: ',INTLST(LIST(5)+I-1), C ' LESS THAN ',SIGLST(LIST(6)+I-1) ELSE PRINT *,'INERTIA: ',INTLST(LIST(5)+I-1), C ' BETWEEN 0 AND ',SIGLST(LIST(6)+I-1) ENDIF 860 CONTINUE ENDIF IF (MOD(IPARAM(10),4)/2.GE.1) THEN * DO A Y-ORTHOGONALITY TEST PRINT *,'Y ORTHOGONALITY' DO 830 I = 1, OEIGNM CALL APPINP(IPARAM(1),WORKV2(LIST(27)),Y(1,ONUMT(I)), C IPARAM(9),IPARAM(17),MAUX,MRP,MCP,IPARAM(15),KAUX,KRP,KCP) DO 840 J = 1, OEIGNM WORKV1(LIST(26)+J-1) = SINPRD(IPARAM(1), C WORKV2(LIST(27)),Y(1,ONUMT(J))) 840 CONTINUE J = 1 PRINT *,'ROW ',I 825 CONTINUE IF (J.GT.I) GOTO 829 PRINT 620,(ABS(WORKV1(LIST(26)+K-1)),K=J,MIN0(J+8,I)) J = J + 9 GOTO 825 829 CONTINUE 830 CONTINUE ENDIF 600 FORMAT('NUM ',' EIGENVALUE',14X,'ESTIMATED ERROR',9X, C 'COMPUTED ERROR') 602 FORMAT('NUM ',' EIGENVALUE',14X,'ESTIMATED ERROR') 604 FORMAT('NUM ',' EIGENVALUE') 605 FORMAT(I3,' ',1PD23.15,' ',1PD23.15,' ',1PD23.15) 615 FORMAT(I3,' ',1PD23.15,' ',1PD23.15) 610 FORMAT(I3,' ',1PD23.15) 620 FORMAT(9(1PD8.1)) 630 FORMAT(' FREQUENCY = ',1PD23.15,' KHZ') 1001 CONTINUE * END OF ERROR CHECKING * NOW FREE SOME MEMORY TMEM = IPARAM(12) * FREE R1THET CALL FFREE(IPARAM(13),0,TMEM,ALIST(1)) * FREE R2THET CALL FFREE(IPARAM(13),0,TMEM,ALIST(2)) * FREE R1BJ CALL FFREE(IPARAM(13),0,TMEM,ALIST(3)) * FREE R2BJ CALL FFREE(IPARAM(13),0,TMEM,ALIST(4)) * FREE INTLST CALL FFREE(IPARAM(2),1,TMEM,ALIST(5)) * FREE SIGLST CALL FFREE(IPARAM(2),0,TMEM,ALIST(6)) * FREE ETA0 CALL FFREE(IPARAM(2),0,TMEM,ALIST(8)) * FREE ETA1 CALL FFREE(IPARAM(2),0,TMEM,ALIST(9)) * FREE NUMT CALL FFREE(IPARAM(13),1,TMEM,ALIST(10)) * FREE Z CALL FFREE((IPARAM(13)+30)*(IPARAM(13)+30),0,TMEM,ALIST(13)) * FREE WORKY CALL FFREE(IPARAM(1)*(IPARAM(13)+1),0,TMEM,ALIST(16)) * FREE P CALL FFREE(IPARAM(1),0,TMEM,ALIST(17)) * FREE P0 CALL FFREE(IPARAM(1),0,TMEM,ALIST(18)) * FREE FRWRKV CALL FFREE((IPARAM(1)+1)*12,0,TMEM,ALIST(21)) * FREE FIWRKV CALL FFREE((IPARAM(1)+1)*2,1,TMEM,ALIST(22)) * FREE ALPHA CALL FFREE(IPARAM(13),0,TMEM,ALIST(23)) * FREE BETA CALL FFREE(IPARAM(13)+1,0,TMEM,ALIST(24)) * FREE WORKV1 CALL FFREE(IPARAM(1),0,TMEM,ALIST(26)) * FREE WORKV2 CALL FFREE(IPARAM(1),0,TMEM,ALIST(27)) * FREE TBETA CALL FFREE(IPARAM(13)+1,0,TMEM,ALIST(28)) * FREE FARP CALL FFREE(IPARAM(1)+1,1,TMEM,ALIST(29)) * FREE FARL CALL FFREE(IPARAM(1)+1,1,TMEM,ALIST(30)) * FREE FA IPARAM(26) = ABS(IPARAM(26)) CALL FFREE(IPARAM(26),0,TMEM,IPARAM(23)) * FREE THE INDICES FOR SPARSE FACTORIZATION IF (IPARAM(24).GE.2) THEN CALL FFREE(IPARAM(21),1,TMEM,IPARAM(28)) ENDIF * FREE TAU0 CALL FFREE(IPARAM(2),0,TMEM,ALIST(33)) * FREE TAU1 CALL FFREE(IPARAM(2),0,TMEM,ALIST(34)) IF (IPARAM(8).GT.0) THEN PRINT *,'LANZ HAS ',TMEM,' BYTES LEFT' ENDIF * PUT THE CORRECT OUTPUT INTO INPARI INPARI(4) = IPARAM(4) INPARI(5) = IPARAM(6) INPARI(6) = IPARAM(7) RETURN END C$FORTRAN DRIVER *********************************************************************** * LANZ SOFTWARE PACKAGE (TEST PROGRAM) * * FILENAME: MAIN.MSC * * AUTHOR: MARK JONES * * PURPOSE: AN EXAMPLE DRIVER TO CALL LANZ() (ALSO USES READIT.MSC* * AND DPREP.MSC) * *********************************************************************** PROGRAM DRIVER * M CONTAINS THE NONZEROES OF THE MASS MATRIX DOUBLE PRECISION M(1) * MRP CONTAINS THE ROW INDICES INTO M INTEGER MRP(1) * MCP CONTAINS THE CORRESPONDING COLUMN NUMBER FOR NONZEROES INTEGER MCP(1) * K CONTAINS THE NONZEROES OF THE STIFFNESS MATRIX DOUBLE PRECISION K(1) * KRP CONTAINS THE ROW INDICES INTO K INTEGER KRP(1) * KCP CONTAINS THE CORRESPONDING COLUMN NUMBER FOR NONZEROES INTEGER KCP(1) * THE ROW TO JOINT VECTOR (IGNORE IF NOT CALLING FROM TESTBED) INTEGER RTOJ(1) * THETA IS THE ARRAY OF CONVERGED EIGENVALUES DOUBLE PRECISION THETA(1) * USED TO STORE THE INITIAL GUESS (IF ANY) VECTOR FOR LANZ DOUBLE PRECISION GUESS(1) * BJ IS AN ARRAY OF ERROR BOUNDS ON CONVERGED EIGENVALUES DOUBLE PRECISION BJ(1) * Y IS THE ARRAY OF EIGENVECTORS DOUBLE PRECISION Y(1) * RELATE MATCHES EIGENVALUES OF THETA WITH EIGENVECTORS IN Y * THETA(I)'S EIGENVECTOR IS IN COLUMN RELATE(I) OF Y INTEGER RELATE(1) * TIPAR IS A SET OF INTEGER PARAMETERS TO CALL LANZ * 1 = THE ORDER OF THE MATRIX * 2 = THE MAXIMUM NUMBER OF EIGENVALUES THAT CAN BE STORED * 3 = THE NUMBER OF EIGENVALUES BEING SOUGHT * 4 = (ON INPUT) THE MAXIMUM NUMBER OF LANCZOS STEPS TO TAKE * (ON OUTPUT) THE NUMBER OF LANCZOS STEPS TAKEN * 5 = THE RETURN VALUE OF LANCZOS (0 MEANS NO ERROR) * 6 = (ON INPUT) THE NUMBER OF EIGENVALUES ALREADY FOUND * (ON OUTPUT) THE NUMBER OF EIGENVALUES CORRECTLY FOUND * 7 = THE LEVEL OF DEBUGGING OUTPUT * 8 = VIBRATION (0) OR BUCKLING (1 W/ SHIFT) (2 W/O SHIFT) * 9 = INERTIA CHECKING (0=NONE, 1=YES) * 10 = AMOUNT OF OUTPUT * 11 = THE MAX. NUMBER OF STEPS ON ONE SHIFT * 12 = TYPE OF EIGENPROBLEM (0=CLOSEST TO SIGMA * 1=SEARCH IN RANGE) * 13 = STORAGE FORMAT FOR K (0=SPARSE,1=FULL) (DON'T USE FULL) * 14 = STORAGE FORMAT FOR M (0=SPARSE,1=FULL) (DON'T USE FULL) * 15 = LEVEL OF LOOP UNROLLING (1,4, OR 6, APPLIES ON TO POSITIVE * DEFINITE SOLVER, THE LEVEL OF * UNROLLING FOR THE INDEFINITE * SOLVER IS SET IN THE MAKEFILE) * 16 = THE TYPE OF FACTORIZATION (0 = BUNCH-KAUFMAN IF INDEFINITE * LDL IF P.D. * 1 = ALWAYS USE LDL * 2 = SAME AS 0 BUT SPARSE * 3 = SAME AS 1 BUT SPARSE) * 17 = DYNAMIC SHIFTING TURNED OFF (0=ON, 1=OFF) * 18 = INITIAL GUESS (1), NO GUESS (0) * 19 = THE LEADING INDEX OF THE ARRAY Y * 20 = THE NUMBER OF DELAYED PIVOTS TO ALLOW SPACE FOR INTEGER TIPAR(20) * TRPAR IS A SET OF FLOAT PARAMETERS FROM THE CALLING ROUTINE * 1 = THE SIGMA TO BE SEARCHED AROUND * 2 = THE REQUIRED RELATIVE ACCURACY OF THE EIGENVALUES * 3 = LEFT SIDE OF BOUNDARY TO SEARCH (IF ANY) * 4 = RIGHT SIDE OF BOUNDARY TO SEARCH (IF ANY) * 5 = THE STORAGE FACTOR FOR BUNCH-KAUFMAN DOUBLE PRECISION TRPAR(5) * VARIABLES FOR USE ONLY IN THIS ROUTINE * THIS ARRAY ISN'T USED IN THIS VERSION, BUT MUST BE INCLUDED INTEGER IOPAR(5) * ADDRESS INDEX VARIABLES * CONTAINS THE OFFSETS OF ALLOCATED MEMORY * ALLOCATED MEMORY IS DESCRIBED IN MEMORY.DOC INTEGER LIST(12) * ACTUAL ADDRESS VARIABLES * CONTAINS THE ACTUAL ADDRESSES OF ALLOCATED MEMORY INTEGER ALIST(12) * THE SIZE OF MEMORY IN THE ARRAY VARIABLES * CONTAINS THE ACTUAL SIZE OF ALLOCATED BLOCKS OF MEMORY INTEGER SLIST(6) * TOTAL AMOUNT OF MEMORY ALLOCATED INTEGER TMEM * INTEGER FUNCTIONS INTEGER UTIME, STIME * CALL TO DPREP TO SET NECESSARY PARAMETERS AND READ IN * THE MATRICES TMEM = 0 CALL DPREP(TIPAR,TRPAR,IOPAR,LIST,SLIST,ALIST,TMEM,K,KRP,KCP, C M,MRP,MCP,RTOJ) * SET THE LEADING INDEX OF Y TIPAR(19) = TIPAR(1) * MANY OF THE VARIABLES ARE ALLOCATED HERE CALL FALLOC(TIPAR(1)*TIPAR(2),0,Y,TMEM,LIST(1),ALIST(1)) CALL FALLOC(TIPAR(2),1,RELATE,TMEM,LIST(2),ALIST(2)) CALL FALLOC(TIPAR(2),0,THETA,TMEM,LIST(3),ALIST(3)) CALL FALLOC(TIPAR(1),0,GUESS,TMEM,LIST(4),ALIST(4)) CALL FALLOC(TIPAR(2),0,BJ,TMEM,LIST(5),ALIST(5)) * 6-12 ALLOCATED IN READIT IF (TIPAR(10).GT.0) THEN PRINT *,'DRIVER ALLOCATED ',TMEM,' BYTES' ENDIF * SET THE NUMBER OF EIGENVALUES ALREADY FOUND TO 0 TIPAR(6) = 0 * START THE TIMER CALL ITIME() CALL TIMON() * CALL LANZ CALL LANZ(TIPAR(19),TIPAR,TRPAR,THETA(LIST(3)),BJ(LIST(5)), C Y(LIST(1)),RELATE(LIST(2)),K(LIST(6)),KRP(LIST(7)), C KCP(LIST(8)),M(LIST(9)),MRP(LIST(10)),MCP(LIST(11)), C GUESS(LIST(4))) * STOP THE TIMER CALL TIMOFF() * PRINT SOME STATISTICS FROM THE RUN IF (TIPAR(10).GT.0) THEN PRINT *,'NUM FOUND = ',TIPAR(6) PRINT *,'STEPS TAKEN = ',TIPAR(4) PRINT *,'RET VAL = ',TIPAR(5) PRINT *,'ELAPSED USER TIME = ',UTIME(), C ' MILLISECONDS' PRINT *,'ELAPSED SYSTEM TIME = ',STIME(), C ' MILLISECONDS' PRINT *,'ELAPSED TOTAL TIME = ',UTIME()+STIME(), C ' MILLISECONDS' ENDIF * NOW FREE SOME MEMORY CALL FFREE(TIPAR(1)*TIPAR(2),0,TMEM,ALIST(1)) CALL FFREE(TIPAR(2),1,TMEM,ALIST(2)) CALL FFREE(TIPAR(2),0,TMEM,ALIST(3)) CALL FFREE(TIPAR(1),0,TMEM,ALIST(4)) CALL FFREE(TIPAR(2),0,TMEM,ALIST(5)) CALL FFREE(SLIST(1),0,TMEM,ALIST(6)) CALL FFREE(SLIST(2),1,TMEM,ALIST(7)) CALL FFREE(SLIST(3),1,TMEM,ALIST(8)) CALL FFREE(SLIST(4),0,TMEM,ALIST(9)) CALL FFREE(SLIST(5),1,TMEM,ALIST(10)) CALL FFREE(SLIST(6),1,TMEM,ALIST(11)) IF (TIPAR(7).GT.0) THEN PRINT *,'TOTAL MEMORY REMAINING = ',TMEM ENDIF END C$FORTRAN MATRT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: MATRT.MSC * * AUTHOR: MARK JONES * * PURPOSE: COLLECTION OF MATRIX ALGEBRA ROUTINES * *********************************************************************** * MULTIPLIES A FULL BAND MATRIX TIMES A VECTOR SUBROUTINE FMTMLT(N,BETA,BETAP,MATRIX,OUTVEC,INVEC) * N IS THE ORDER OF THE MATRIX INTEGER N * BETA (BETAP) IS THE BANDWIDTH (+1) OF THE MATRIX INTEGER BETA, BETAP * MATRIX IS THE BAND MATRIX DOUBLE PRECISION MATRIX(*) * OUTVEC IS THE PRODUCT VECTOR DOUBLE PRECISION OUTVEC(*) * INVEC IS THE INCOMING VECTOR DOUBLE PRECISION INVEC(*) * INTERNAL VARIABLE NAMES * ALL COUNT VARIABLES INTEGER I,J INTEGER START,FINISH * MULTIPLY BY THE DIAGONAL DO 5 J = 1, N OUTVEC(J) = INVEC(J)*MATRIX((J*BETAP)+1) 5 CONTINUE * MULTIPLY BY OFF DIAGONALS DO 10 I = 1, BETA START = 1 + I FINISH = N - I DO 20 J = 1, FINISH OUTVEC(J) = OUTVEC(J) + C INVEC(J+I)*MATRIX((J*BETAP)+START) 20 CONTINUE DO 30 J = 1, FINISH OUTVEC(J+I) = OUTVEC(J+I) + C INVEC(J)*MATRIX((J*BETAP)+START) 30 CONTINUE 10 CONTINUE RETURN END * MULTIPLIES A FULL BAND MATRIX (STORED DIAGONALLY) BY A VECTOR SUBROUTINE DMTMLT(N,BETA,BETAP,MATRIX,OUTVEC,INVEC) * N IS THE ORDER OF THE MATRIX INTEGER N * BETA (BETAP) IS THE BANDWIDTH (+1) OF THE MATRIX INTEGER BETA, BETAP * MATRIX IS THE BAND MATRIX DOUBLE PRECISION MATRIX(*) * OUTVEC IS THE PRODUCT VECTOR DOUBLE PRECISION OUTVEC(*) * INVEC IS THE INCOMING VECTOR DOUBLE PRECISION INVEC(*) * INTERNAL VARIABLE NAMES * ALL COUNT VARIABLES INTEGER I,J INTEGER START,FINISH * MULTIPLY BY THE DIAGONAL DO 5 J = 1, N OUTVEC(J) = INVEC(J)*MATRIX(J) 5 CONTINUE * MULTIPLY BY OFF DIAGONALS DO 10 I = 1, BETA START = I*N FINISH = N - I DO 20 J = 1, FINISH OUTVEC(J) = OUTVEC(J) + C INVEC(J+I)*MATRIX(START+J) 20 CONTINUE DO 30 J = 1, FINISH OUTVEC(J+I) = OUTVEC(J+I) + C INVEC(J)*MATRIX(START+J) 30 CONTINUE 10 CONTINUE RETURN END * MULTIPLIES A SPARSE MATRIX BY A VECTOR SUBROUTINE SMTMLT(N,D,A,CP,RP,TA,TCP,TRP,OUTVEC,INVEC) * N IS THE ORDER OF THE MATRIX INTEGER N * DIAGONAL OF THE MATRIX DOUBLE PRECISION D(*) * OFF-DIAGONALS OF THE MATRIX DOUBLE PRECISION A(*), TA(*) * COLUMN INDICES INTEGER CP(*), TCP(*) * ROW NUMBERS OF OFF-DIAGONALS INTEGER RP(*), TRP(*) * OUTVEC IS THE PRODUCT VECTOR DOUBLE PRECISION OUTVEC(*) * INVEC IS THE INCOMING VECTOR DOUBLE PRECISION INVEC(*) * INTERNAL VARIABLE NAMES * ALL COUNT VARIABLES INTEGER I,J * TEMPORARY VARIABLES INTEGER IROW DOUBLE PRECISION X, SUM * MULTIPLY BY THE DIAGONAL DO 10 I = 1, N OUTVEC(I) = INVEC(I)*D(I) 10 CONTINUE IF (CP(N+1).EQ.1) RETURN * MULTIPLY BY THE OFF-DIAGONALS DO 20 I = 1, N SUM = 0.0D0 DO 30 J = CP(I), CP(I+1)-1 SUM = SUM+A(J)*INVEC(RP(J)) 30 CONTINUE DO 40 J = TCP(I)+1, TCP(I+1)-1 SUM = SUM+TA(J)*INVEC(TRP(J)) 40 CONTINUE OUTVEC(I) = OUTVEC(I)+SUM 20 CONTINUE RETURN END * MULTIPLIES THE STIFFNESS MATRIX TIMES A VECTOR SUBROUTINE KAPPLY(N,OUTVEC,INVEC,KFORM,KAUX,KRP,KCP) * N IS THE ORDER OF THE MATRIX INTEGER N * OUTVEC IS THE PRODUCT VECTOR DOUBLE PRECISION OUTVEC(*) * INVEC IS THE INCOMING VECTOR DOUBLE PRECISION INVEC(*) * KFORM IS THE FORM THAT K IS STORED IN INTEGER KFORM * KAUX IS THE STIFFNESS MATRIX STORED IN ANOTHER FORM DOUBLE PRECISION KAUX(*) * KRP IS AN AUXILLARY VECTOR INTEGER KRP(*) * KCP IS AN AUXILLARY VECTOR INTEGER KCP(*) EXTERNAL SMTMLT, FLLMLT IF (KFORM.EQ.0) THEN CALL SMTMLT(N,KAUX,KAUX(N+1),KRP,KCP, C KAUX(N+KRP(N+1)),KRP(N+2),KCP(KRP(N+1)+1),OUTVEC,INVEC) ELSE IF (KFORM.EQ.1) THEN CALL FLLMLT(KRP(1),N,N,OUTVEC,KAUX,INVEC,0) ELSE PRINT *,'ERROR: K IS NOT STORED IN ANY OTHER FORMAT' PRINT *,'REMEDY: CONTACT TESTBED ADMINISTRATOR' STOP ENDIF RETURN END * MULTIPLIES THE MASS MATRIX TIMES A VECTOR SUBROUTINE MAPPLY(N,OUTVEC,INVEC,MFORM,MAUX,MRP,MCP) * N IS THE ORDER OF THE MATRIX INTEGER N * OUTVEC IS THE PRODUCT VECTOR DOUBLE PRECISION OUTVEC(*) * INVEC IS THE INCOMING VECTOR DOUBLE PRECISION INVEC(*) * THE FORM BY WHICH WE WANT TO MULTIPLY M INTEGER MFORM * MAUX IS THE MASS MATRIX STORED IN ANOTHER FORM DOUBLE PRECISION MAUX(*) * MRP IS AN AUXILLARY VECTOR INTEGER MRP(*) * MCP IS AN AUXILLARY VECTOR INTEGER MCP(*) EXTERNAL SMTMLT, FLLMLT IF (MFORM.EQ.0) THEN CALL SMTMLT(N,MAUX,MAUX(N+1),MRP,MCP, C MAUX(N+MRP(N+1)),MRP(N+2),MCP(MRP(N+1)+1),OUTVEC,INVEC) ELSE IF (MFORM.EQ.1) THEN CALL FLLMLT(MRP(1),N,N,OUTVEC,MAUX,INVEC,0) ELSE PRINT *,'ERROR: M IS NOT STORED IN ANY OTHER FORMAT' PRINT *,'REMEDY: CONTACT TESTBED ADMINISTRATOR' STOP ENDIF RETURN END * APPLIES THE APPROPRIATE INNER PRODUCT SUBROUTINE APPINP(N,OUTVEC,INVEC,PROB, C MFORM,MAUX,MRP,MCP,KFORM,KAUX,KRP,KCP) * N IS THE ORDER OF THE MATRIX INTEGER N * OUTVEC IS THE PRODUCT VECTOR DOUBLE PRECISION OUTVEC(*) * INVEC IS THE INCOMING VECTOR DOUBLE PRECISION INVEC(*) * VIBRATION (0) OR BUCKLING (1) INTEGER PROB * THE FORM BY WHICH WE WANT TO MULTIPLY M INTEGER MFORM * MAUX IS THE MASS MATRIX STORED IN ANOTHER FORM DOUBLE PRECISION MAUX(*) * MRP IS AN AUXILLARY VECTOR INTEGER MRP(*) * MCP IS AN AUXILLARY VECTOR INTEGER MCP(*) * THE FORM BY WHICH WE WANT TO MULTIPLY K INTEGER KFORM * KAUX IS THE STIFFNESS MATRIX STORED IN ANOTHER FORM DOUBLE PRECISION KAUX(*) * KRP IS AN AUXILLARY VECTOR INTEGER KRP(*) * KCP IS AN AUXILLARY VECTOR INTEGER KCP(*) EXTERNAL MAPPLY, KAPPLY, CPYVEC IF (PROB.EQ.0) THEN CALL MAPPLY(N,OUTVEC,INVEC,MFORM,MAUX,MRP,MCP) ELSE IF (PROB.EQ.1) THEN CALL KAPPLY(N,OUTVEC,INVEC,KFORM,KAUX,KRP,KCP) ELSE IF (PROB.EQ.2) THEN * THIS IS JUST A NORMAL INNER PRODUCT, SO DO NOTHING CALL CPYVEC(N,OUTVEC,INVEC) ENDIF RETURN END * MULTIPLIES (K-SIGMA*M) TIMES A VECTOR SUBROUTINE PENMLT(N,INVEC,OUTVEC,WORKV,SIGMA,KFORM, C KAUX,KRP,KCP,MFORM,MAUX,MRP,MCP,PROB) * N IS THE ORDER OF THE MATRIX INTEGER N * INVEC IS THE INCOMING VECTOR DOUBLE PRECISION INVEC(*) * OUTVEC IS THE PRODUCT VECTOR DOUBLE PRECISION OUTVEC(*) * A WORKING VECTOR DOUBLE PRECISION WORKV(*) * THE SHIFT FACTOR DOUBLE PRECISION SIGMA * THE FORM BY WHICH WE WANT TO MULTIPLY K INTEGER KFORM * KAUX IS THE STIFFNESS MATRIX STORED IN ANOTHER FORM DOUBLE PRECISION KAUX(*) * KRP IS AN AUXILLARY VECTOR INTEGER KRP(*) * KCP IS AN AUXILLARY VECTOR INTEGER KCP(*) * THE FORM BY WHICH WE WANT TO MULTIPLY M INTEGER MFORM * MAUX IS THE MASS MATRIX STORED IN ANOTHER FORM DOUBLE PRECISION MAUX(*) * MRP IS AN AUXILLARY VECTOR INTEGER MRP(*) * MCP IS AN AUXILLARY VECTOR INTEGER MCP(*) * WHAT DO YOU WANT THE PENCIL OF? INTEGER PROB EXTERNAL MAPPLY, KAPPLY, VECSUB, VECXSC IF (PROB.EQ.0) THEN CALL KAPPLY(N,OUTVEC,INVEC,KFORM,KAUX,KRP,KCP) IF (SIGMA.NE.0.0D0) THEN CALL MAPPLY(N,WORKV,INVEC,MFORM,MAUX,MRP,MCP) CALL VECXSC(N,WORKV,WORKV,SIGMA) CALL VECSUB(N,OUTVEC,OUTVEC,WORKV) END IF ELSE CALL MAPPLY(N,OUTVEC,INVEC,MFORM,MAUX,MRP,MCP) IF (SIGMA.NE.0.0D0) THEN CALL KAPPLY(N,WORKV,INVEC,KFORM,KAUX,KRP,KCP) CALL VECXSC(N,WORKV,WORKV,SIGMA) CALL VECSUB(N,OUTVEC,OUTVEC,WORKV) END IF ENDIF RETURN END * INITIALIZE A MATRIX TO THE IDENTITY SUBROUTINE MATEYE(LDI,N,MAT) * THE LEADING INDEX OF THE MATRIX INTEGER LDI * N IS THE ORDER OF THE MATRIX INTEGER N * THE MATRIX DOUBLE PRECISION MAT(LDI,*) * INTERNAL VARIABLES INTEGER I, J DO 10 I = 1, N DO 20 J = 1, N MAT(I,J) = 0.0D0 20 CONTINUE MAT(I,I) = 1.0D0 10 CONTINUE RETURN END C$FORTRAN BOPER *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: MATSLV.MSC * * AUTHOR: MARK JONES * * PURPOSE: USED TO PERFORM THE REQUIRED TRANSFORMATION. WILL * * CALL THE NECESSARY FACTORIZATION AND SOLUTION ROUTINES* *********************************************************************** SUBROUTINE BOPER(N,B,X,SIGMA,METHOD,FACTOP,FACTYP, C FALEAD,FA,FARP,FARL,IWRKV,RWRKV,INTLST, C SIGLST,INTIDX,DEBUG,NROLL,SPFLAG,FASIZE,FAADDR,TMEM, C KFORM,KAUX,KRP,KCP, C MFORM,MAUX,MRP,MCP,BFACT,MAXDLY,INSIZE,INPTR,INADDR) * N IS THE ORDER OF THE MATRIX INTEGER N * B IS THE RIGHT HAND SIDE DOUBLE PRECISION B(*) * X IS THE VECTOR BEING SOLVED FOR DOUBLE PRECISION X(*) * SIGMA IS THE SHIFT DOUBLE PRECISION SIGMA * METHOD IS THE PROBLEM TYPE (SEE IPAR(8) IN MAIN.MSC) INTEGER METHOD * FACTOP INDICATES (IF METHOD NEEDS) WHAT COMBINATION OF * FACTORIZATION, FORWARD OR BACK SOLVE IS NEEDED * 0 MEANS DO FACT, FORW, BACK * 1 MEANS DO FORW, BACK * 2 MEANS DO FACT, FORW * 3 MEANS DO FORW * 4 MEANS DO FACT, BACK * 5 MEANS DO BACK * 6 MEANS ONLY FACTOR INTEGER FACTOP * THE TYPE OF FACTORIZATION (SEE IPAR(16) IN MAIN.MSC) INTEGER FACTYP * THE MEMORY OFFSET INDEX OF FA (SET BY MEMORY ALLOCATION * IN EITHER NWSLVE OR BUNSET, NOT USED ANYWHERE ELSE) INTEGER FALEAD * FA, FARP, AND FARL ARE NOT USED ELSEWHERE * THEY ARE CURRENTLY STORING THE FACTORS IN VARIABLE BAND * FORM, BUT COULD BE USED FOR SOMETHING ELSE AS WELL * CURRENTLY FARP AND FARL ARE ALLOCATED AS LENGTH N+1 IN * LANZ.MSC * STORAGE FOR THE FACTORED MATRIX DOUBLE PRECISION FA(*) * FARP IS THE VECTOR OF ROW POINTERS FOR FA INTEGER FARP(*) * FARL IS THE VECTOR OF ROW LENGTHS FOR FA INTEGER FARL(*) * WORK SPACE FOR USE IN FACTORIZATION. ALLOCATED IN LANZ.MSC * THE WORK VECTORS INTEGER IWRKV(N+1,*) DOUBLE PRECISION RWRKV(N+1,*) * AN ARRAY OF THE COUNTS OF THE NUMBER OF EIGENVALUES TO LEFT * OF EACH SHIFT TAKEN. INTLST(I) IS ASSOCIATED WITH SIGLST(I) * A LIST OF INERTIA CALCULATIONS INTEGER INTLST(*) * AN ARRAY OF THE SHIFTS TAKEN * A LIST OF SIGMAS DOUBLE PRECISION SIGLST(*) * THE NUMBER OF SHIFTS TAKEN THUS FAR * THE NUMBER OF SIGMAS AND INERTIA INTEGER INTIDX * THE LEVEL OF DEBUGGING OUTPUT. ZERO MEANS NO OUTPUT * THE LEVEL OF DEBUGGING INTEGER DEBUG * THE LEVEL OF LOOP UNROLLING IN THE P.D. SOLVE (1,4, OR 6) * CAN CURRRENTLY BE USED IN NWSLVE() * THE LEVEL OF LOOP UNROLLING INTEGER NROLL * A FLAG THAT TELLS THE BUNSET PROCEDURE WHETHER THE SPACE * NEEDED FOR FACTORIZATION HAS BEEN CALCULATED INTEGER SPFLAG * THE SIZE OF FA INTEGER FASIZE * THE ACTUAL ADDRESS OF FA INTEGER FAADDR * THE TOTAL AMOUNT OF MEMORY ALLOCATED INTEGER TMEM * THE FORM K IS STORED IN (0=SPARSE) INTEGER KFORM * KAUX IS THE K MATRIX DOUBLE PRECISION KAUX(*) * KRP IS THE ROW POINTERS INTO K INTEGER KRP(*) * KCP IS THE LIST OF COLUMN NUMBERS FOR K INTEGER KCP(*) * THE FORM M IS STORED IN (0=SPARSE) INTEGER MFORM * MAUX IS THE M MATRIX DOUBLE PRECISION MAUX(*) * MCP IS THE LIST OF COLUMN NUMBERS FOR M INTEGER MRP(*) * KCP IS THE LIST OF COLUMN NUMBERS FOR K INTEGER MCP(*) * THE B-K STORAGE FACTOR (SEE RPAR(5) IN MAIN.MSC) DOUBLE PRECISION BFACT * THE MAXIMUM NUMBER OF DELAYED PIVOTS THAT CAN BE STORED INTEGER MAXDLY * SIZE OF INDICES INTO FACTORED MATRIX (FOR SPARSE FACTOR) INTEGER INSIZE * OFFSET ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INPTR * ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INADDR * INTERNAL VARIABLE NAMES * INDICATES IF THE SPARSE FORMAT NEEDS TO BE DONE IN B-K LOGICAL DOSP EXTERNAL FFREE, SPSET, PENMLT, NWSLVE, BUNSET * IF WE ARE STARTING A NEW FACTORIZATION, THEN FREE THE * SPACE FROM THE OLD ONE IF ((MOD(FACTOP,2).EQ.0).AND.(FASIZE.GT.0).AND. C (FACTYP.LE.1)) THEN CALL FFREE(FASIZE,0,TMEM,FAADDR) ENDIF * IF WE ARE SUPPOSED TO DO SPARSE FACTORIZATION IF ((FACTYP.GE.2).AND.(FACTYP.LE.4)) THEN IF (METHOD.LT.2) THEN CALL SPSET(N,B,X,SIGMA,FACTOP,FALEAD,FA,FARP, C FARL,IWRKV,RWRKV,INTLST,SIGLST,INTIDX,METHOD, C DEBUG,NROLL,MAUX,MAUX(N+1),MRP,MCP,KAUX, C KAUX(N+1),KRP,KCP, C KAUX(N+KRP(N+1)),KRP(N+2),KCP(KRP(N+1)+1), C MAUX(N+MRP(N+1)),MRP(N+2),MCP(MRP(N+1)+1), C FASIZE,FAADDR,TMEM,FACTYP,MAXDLY,INSIZE,INPTR,INADDR) ELSE IF (FACTOP.EQ.0) THEN FACTOP = 4 ELSE FACTOP = 5 ENDIF * NOTE: WE USE RWKRV(1,1 AND 2) BECAUSE NO ONE NEEDS IT CALL SPSET(N,B,X,SIGMA,FACTOP,FALEAD,FA,FARP, C FARL,IWRKV,RWRKV,INTLST,SIGLST,INTIDX,METHOD, C DEBUG,NROLL,MAUX,MAUX(N+1),MRP,MCP,KAUX, C KAUX(N+1),KRP,KCP, C KAUX(N+KRP(N+1)),KRP(N+2),KCP(KRP(N+1)+1), C MAUX(N+MRP(N+1)),MRP(N+2),MCP(MRP(N+1)+1), C FASIZE,FAADDR,TMEM,FACTYP,MAXDLY,INSIZE,INPTR,INADDR) * HERE, AS PART OF THE TRANSFORMATION (SEE REFERENCES FOR * DETAILS), WE MULTIPLY BY M CALL PENMLT(N,X,RWRKV(1,2),RWRKV(1,1),SIGMA,KFORM, C KAUX,KRP,KCP,MFORM, C MAUX,MRP,MCP,1) IF (FACTOP.EQ.0) THEN FACTOP = 2 ELSE FACTOP = 3 ENDIF CALL SPSET(N,RWRKV(1,2),X,SIGMA,FACTOP,FALEAD,FA, C FARP,FARL,IWRKV,RWRKV,INTLST,SIGLST,INTIDX,METHOD, C DEBUG,NROLL,MAUX,MAUX(N+1),MRP,MCP,KAUX, C KAUX(N+1),KRP,KCP, C KAUX(N+KRP(N+1)),KRP(N+2),KCP(KRP(N+1)+1), C MAUX(N+MRP(N+1)),MRP(N+2),MCP(MRP(N+1)+1), C FASIZE,FAADDR,TMEM,FACTYP,MAXDLY,INSIZE,INPTR,INADDR) ENDIF * IF WE SHOULD DO BAND FACTORIZATION ELSE IF (FACTYP.LE.1) THEN * IF WE KNOW THAT (K-S M) IS POSITIVE DEFINITE * OR WE ARE TOLD TO USE LDL THEN CALL NWSLVE * AND WE ARE WORKING ON THE VIBRATION PROBLEM IF ((METHOD.LT.2).AND.((SIGMA.EQ.0).OR.(FACTYP.EQ.1).OR. C ((SIGMA.LT.0).AND.(METHOD.EQ.0)))) THEN CALL NWSLVE(N,B,X,SIGMA,FACTOP,FALEAD,FA,FARP, C FARL,INTLST,SIGLST,INTIDX,METHOD, C DEBUG,NROLL,MAUX,MAUX(N+1),MRP,MCP,KAUX, C KAUX(N+1),KRP,KCP,FASIZE,FAADDR,TMEM) * OTHERWISE, CALL BUNSET FOR THE INDEFINITE PROBLEMS ELSE IF (METHOD.LT.2) THEN IF (SPFLAG.EQ.0) THEN SPFLAG = 1 DOSP = .TRUE. ELSE DOSP = .FALSE. ENDIF CALL BUNSET(N,B,X,SIGMA,FACTOP,FALEAD,FA,FARP, C FARL,IWRKV,RWRKV,INTLST,SIGLST,INTIDX,METHOD, C DEBUG,NROLL,MAUX,MAUX(N+1),MRP,MCP,KAUX, C KAUX(N+1),KRP,KCP,DOSP, C KAUX(N+KRP(N+1)),KRP(N+2),KCP(KRP(N+1)+1), C MAUX(N+MRP(N+1)),MRP(N+2),MCP(MRP(N+1)+1), C FASIZE,FAADDR,TMEM,BFACT) * HERE ALL WE WANT IS A CHOLESKI FACTORIZATION OF K * BECAUSE NO SHIFT IS USED. WE FIRST MULTIPLY BY L(-T), THEN * BY M, THEN BY L(-1) ELSE IF (FACTOP.EQ.0) THEN FACTOP = 4 ELSE FACTOP = 5 ENDIF * NOTE: WE USE RWKRV(1,1 AND 2) BECAUSE NO ONE NEEDS IT CALL NWSLVE(N,B,X,SIGMA,FACTOP,FALEAD,FA,FARP, C FARL,INTLST,SIGLST,INTIDX,METHOD,DEBUG, C NROLL,MAUX,MAUX(N+1),MRP,MCP,KAUX, C KAUX(N+1),KRP,KCP,FASIZE,FAADDR,TMEM) * HERE, AS PART OF THE TRANSFORMATION (SEE REFERENCES FOR * DETAILS), WE MULTIPLY BY M CALL PENMLT(N,X,RWRKV(1,2),RWRKV(1,1),SIGMA,KFORM, C KAUX,KRP,KCP,MFORM, C MAUX,MRP,MCP,1) IF (FACTOP.EQ.0) THEN FACTOP = 2 ELSE FACTOP = 3 ENDIF CALL NWSLVE(N,RWRKV(1,2),X,SIGMA,FACTOP,FALEAD,FA, C FARP,FARL,INTLST,SIGLST,INTIDX,METHOD, C DEBUG,NROLL,MAUX,MAUX(N+1),MRP,MCP,KAUX,KAUX(N+1), C KRP,KCP,FASIZE,FAADDR,TMEM) ENDIF ENDIF RETURN END * A ROUTINE THAT SETS UP THE CALL TO A FACTOR/SOLVE ROUTINE * FOR POSITIVE DEFINITE MATRICES SUBROUTINE NWSLVE(N,B,X,SIGMA,INFLAG,FALEAD,FA,FARP, C FARL,INTLST,SIGLST,INTIDX,PROB, C DEBUG,NROLL,MDIAG,MSPAR,MRP,MCP, C KDIAG,KSPAR,KRP,KCP,FASIZE,FAADDR,TMEM) * N IS THE ORDER OF THE MATRIX INTEGER N * B IS THE RIGHT HAND SIDE DOUBLE PRECISION B(*) * X IS THE VECTOR BEING SOLVED FOR DOUBLE PRECISION X(*) * SIGMA IS THE SHIFT DOUBLE PRECISION SIGMA * INDICATES WHAT COMBINATION OF FACTORIZATION, BACK AND FORWARD * SOLVE TO DO INTEGER INFLAG * THE LEADING INDEX OF FA INTEGER FALEAD * STORAGE FOR THE FACTORED MATRIX DOUBLE PRECISION FA(*) * FARP IS THE VECTOR OF ROW POINTERS FOR FA INTEGER FARP(*) * FARL IS THE VECTOR OF ROW LENGTHS FOR FA INTEGER FARL(*) * A LIST OF INERTIA CALCULATIONS INTEGER INTLST(*) * A LIST OF SIGMAS DOUBLE PRECISION SIGLST(*) * THE NUMBER OF SIGMAS AND INERTIA INTEGER INTIDX * PROBLEM TYPE INTEGER PROB * THE LEVEL OF DEBUGGING INTEGER DEBUG * THE LEVEL OF LOOP UNROLLING INTEGER NROLL * THE DIAGONALS OF THE M MATRIX DOUBLE PRECISION MDIAG(*) * THE OFF-DIAGONALS OF THE M MATRIX DOUBLE PRECISION MSPAR(*) * THE ROW POINTERS IN MSPAR INTEGER MRP(*) * THE COLUMN NUMBERS FOR MCP INTEGER MCP(*) * THE DIAGONALS OF THE K MATRIX DOUBLE PRECISION KDIAG(*) * THE OFF-DIAGONALS OF THE K MATRIX DOUBLE PRECISION KSPAR(*) * THE ROW POINTERS FOR KSPAR INTEGER KRP(*) * THE COLUMN NUMBERS FOR KSPAR INTEGER KCP(*) * THE SIZE OF FA INTEGER FASIZE * THE DOUBLE PRECISION ADDRESS OF FA INTEGER FAADDR * THE TOTAL MEMORY ALLOCATED INTEGER TMEM * INTERNAL VARIABLE NAMES * COUNT VARIABLES INTEGER I, J, OFFSP, OFFDI, FLOPS INTEGER ICX, LENGTH, MICX, MCOL, KICX, IADD, LASTR * THE TYPE OF SOLVE OPERATION TO DO INTEGER SOPER * THE MAXIMUM BANDWIDTH IN FA INTEGER MAXBND * THE NUMBER OF OPERATIONS INTEGER NOPS * THE NUMBER OF NEGATIVE DIAGONALS INTEGER NNEG * INTEGER FUNCTIONS INTEGER LOCAL2 EXTERNAL LOCAL2, L2TMON, L2TMOF, FALLOC, VBLDNZ, VBLDSZ EXTERNAL VBLDS4, VBLDS6, CPYVEC * 0 MEANS DO FACT, FORW, BACK * 1 MEANS DO FORW, BACK * 2 MEANS DO FACT, FORW * 3 MEANS DO FORW * 4 MEANS DO FACT, BACK * 5 MEANS DO BACK * 6 MEANS ONLY FACTOR IF (DEBUG.NE.0) THEN CALL L2TMON() ENDIF * SET UP FOR FACTORIZATION IF NECESSARY IF ((INFLAG.EQ.0).OR.(INFLAG.EQ.2).OR.(INFLAG.EQ.4).OR. C (INFLAG.EQ.6)) THEN FLOPS = 0 * ADJUST TO SOLVE K+SIGMA*M RATHER THAN K-SIGMA*M IF ((PROB.EQ.1).OR.(PROB.EQ.2)) THEN SIGMA = -SIGMA ENDIF * FORM THE ARRAY THAT GIVES THE ROW LENGTH FROM THE MAIN * DIAGONAL TO THE LAST NON-ZERO IN A ROW IF (SIGMA.NE.0.0D0) THEN DO 10 I = 1, N-1 MICX = MAX0(1,MRP(I+1)-1) MCOL = MAX0(I,MCP(MICX)) KICX = MAX0(1,KRP(I+1)-1) FARL(I) = MAX0(MCOL,KCP(KICX)) - I + 1 10 CONTINUE ELSE DO 15 I = 1, N-1 KICX = MAX0(1,KRP(I+1)-1) FARL(I) = MAX0(I,KCP(KICX)) - I + 1 15 CONTINUE ENDIF FARL(N) = 1 * ADJUST FOR FILL DURING FACTORIZATION DO 20 I = 2, N FARL(I) = MAX0(FARL(I-1)-1,FARL(I)) 20 CONTINUE * ADJUST FOR LOOP UNROLLING IF NROLL.GT.1 IF (NROLL.GT.1) THEN LASTR = N - MOD(N,NROLL) - 1 DO 30 I = NROLL-1, LASTR, NROLL LENGTH = FARL(I+1) IADD = 1 DO 40 J = I, I-NROLL+2, -1 FARL(J) = LENGTH + IADD IADD = IADD + 1 40 CONTINUE 30 CONTINUE * FIX UP THE END IF N MOD NROLL NE 0 IADD = 1 DO 50 I = N-1, LASTR+2, -1 FARL(I) = FARL(N) + IADD IADD = IADD + 1 50 CONTINUE ENDIF * FIGURE OUT SOME BANDWIDTH STATISTICS AND FORM FARP FARP(1) = 1 DO 70 I = 2, N+1 FARP(I) = FARP(I-1) + FARL(I-1) 70 CONTINUE IF (DEBUG.GT.0) THEN MAXBND = 0 DO 60 I = 1, N MAXBND = MAX0(MAXBND,FARL(I)) 60 CONTINUE PRINT *,'SIGMA = ',SIGMA PRINT *,'MAXIMUM BAND WIDTH = ',MAXBND PRINT *,'AVERAGE BAND WIDTH = ',(FARP(N+1)-1)/N PRINT *,'STORAGE FOR FACTORED MATRIX = ',FARP(N+1)-1+N ENDIF * NOW ALLOCATE ENOUGH SPACE FOR FA FASIZE = FARP(N+1)-1+N CALL FALLOC(FASIZE,0,FA,TMEM,FALEAD,FAADDR) OFFSP = FALEAD + N - 1 OFFDI = FALEAD - 1 * NOW ZERO OUT FA ARRAY DO 80 I = 1+OFFDI, FASIZE+OFFDI FA(I) = 0.0D0 80 CONTINUE * PUT THE OFF-DIAGONALS OF K INTO THE FA ARRAY DO 90 I = 1, N DO 100 J = KRP(I), KRP(I+1)-1 FA(FARP(I)+KCP(J)-I+OFFSP) = KSPAR(J) 100 CONTINUE 90 CONTINUE * PUT THE DIAGONALS OF K INTO THE FA ARRAY (BOTH IN THE VBAND * AND AT THE BEGINNING) DO 110 I = 1, N FA(I+OFFDI) = KDIAG(I) 110 CONTINUE DO 120 I = 1, N FA(FARP(I)+OFFSP) = KDIAG(I) 120 CONTINUE * NOW PUT M (IF SIGMA NE 0) INTO FA IF (SIGMA.NE.0.0D0) THEN * PUT THE OFF-DIAGONALS OF M INTO THE FA ARRAY DO 130 I = 1, N CNORECUR DO 140 J = MRP(I), MRP(I+1)-1 ICX = FARP(I) + MCP(J) - I + OFFSP FA(ICX) = FA(ICX) - SIGMA*MSPAR(J) FLOPS = FLOPS + 2 140 CONTINUE 130 CONTINUE * PUT THE DIAGONALS OF M INTO THE FA ARRAY (BOTH IN THE * VBAND AND AT THE BEGINNING) DO 150 I = 1, N FA(I+OFFDI) = FA(I+OFFDI) - SIGMA*MDIAG(I) 150 CONTINUE FLOPS = FLOPS + 2*N CNORECUR DO 160 I = 1, N FA(FARP(I)+OFFSP) = FA(FARP(I)+OFFSP) - SIGMA*MDIAG(I) 160 CONTINUE FLOPS = FLOPS + 2*N ENDIF IF (DEBUG.NE.0) THEN CALL L2TMON() ENDIF * CALL GENE POOLE'S VARIABLE BAND FACTORIZATION ROUTINE CALL VBLDNZ(FA(FALEAD+N),FARP(N+1)-1,FA(FALEAD),FARP, C FARL,N,NOPS,NNEG,NROLL) IF (DEBUG.NE.0) THEN CALL L2TMOF() PRINT *,'TIME FOR FACTORIZATION = ',LOCAL2() ENDIF IF (PROB.EQ.2) THEN * MAKE THIS A CHOLESKI FACTORIZATION CNORECUR DO 200 I = 1, N FA(I+OFFDI) = SQRT(FA(I+OFFDI)) FA(FARP(I)+OFFSP) = FA(I+OFFDI) 200 CONTINUE ENDIF IF (DEBUG.GT.0) THEN PRINT *,'NUMBER OF SETUP FLOPS = ',FLOPS PRINT *,'NUMBER OF FACTOR OPS = ',NOPS PRINT *,'NUMBER OF NEGATIVE DIAGONALS = ',NNEG ENDIF * SET THE INERTIA COUNTS IN THE ARRAYS INTIDX = INTIDX + 1 INTLST(INTIDX) = NNEG SIGLST(INTIDX) = SIGMA * RE-ADJUST SIGMA IF ((PROB.EQ.1).OR.(PROB.EQ.2)) THEN SIGMA = -SIGMA SIGLST(INTIDX) = -SIGLST(INTIDX) ENDIF IF (PROB.EQ.2) THEN INTIDX = INTIDX - 1 ENDIF IF (DEBUG.NE.0) THEN CALL L2TMOF() PRINT *,'TIME FOR FACTORIZATION = ',LOCAL2() ENDIF ENDIF IF (INFLAG.EQ.6) THEN RETURN ENDIF IF (DEBUG.NE.0) THEN CALL L2TMON() ENDIF * NOW, SET UP THE CALL TO ONE OF GENE'S SOLVERS * 0 MEANS DO FACT, FORW, BACK * 1 MEANS DO FORW, BACK * 2 MEANS DO FACT, FORW * 3 MEANS DO FORW * 4 MEANS DO FACT, BACK * 5 MEANS DO BACK CALL CPYVEC(N,X,B) SOPER = INFLAG/2 * CALL ONE OF THE SOLVERS IF (NROLL.EQ.1) THEN CALL VBLDSZ(FA(FALEAD+N),FARP(N+1)-1,FA(FALEAD), C FARP,FARL,N,X,NOPS,SOPER) ELSE IF (NROLL.EQ.4) THEN CALL VBLDS4(FA(FALEAD+N),FARP(N+1)-1,FA(FALEAD), C FARP,FARL,N,X,NOPS,SOPER) ELSE IF (NROLL.EQ.6) THEN CALL VBLDS6(FA(FALEAD+N),FARP(N+1)-1,FA(FALEAD), C FARP,FARL,N,X,NOPS,SOPER) ELSE PRINT *,'ERROR: THIS LEVEL OF LOOP UNROLLING IS NOT OKAY' PRINT *,'REMEDY: CHANGE LOOP' STOP ENDIF IF (DEBUG.NE.0) THEN CALL L2TMOF() PRINT *,'USED ',NOPS,' FOR THE SOLVE' PRINT *,'TIME FOR SOLVE = ',LOCAL2() ENDIF RETURN END * THIS ROUTINE SETS UP THE CALL TO A B-K TYPE FACTORIZATION * AND SOLUTION ROUTINE FOR INDEFINITE MATRICES SUBROUTINE BUNSET(N,B,X,SIGMA,INFLAG,FALEAD,FA,FARP, C FARL,IWRKV,RWRKV,INTLST,SIGLST,INTIDX,PROB,DEBUG,NROLL, C MDIAG,MSPAR,MRP,MCP,KDIAG,KSPAR,KRP,KCP,DOSP, C TK,TKRP,TKCP,TM,TMRP,TMCP,FASIZE,FAADDR,TMEM,BFACT) * N IS THE ORDER OF THE MATRIX INTEGER N * B IS THE RIGHT HAND SIDE DOUBLE PRECISION B(*) * X IS THE VECTOR BEING SOLVED FOR DOUBLE PRECISION X(*) * SIGMA IS THE SHIFT DOUBLE PRECISION SIGMA * INDICATES WHAT COMBINATION OF FACTORIZATION, BACK AND FORWARD * SOLVE TO DO INTEGER INFLAG * THE LEADING INDEX OF FA INTEGER FALEAD * STORAGE FOR THE FACTORED MATRIX DOUBLE PRECISION FA(*) * FARP IS THE VECTOR OF ROW POINTERS FOR FA INTEGER FARP(*) * FARL IS THE VECTOR OF ROW LENGTHS FOR FA INTEGER FARL(*) * THE INTEGER AND DOUBLE PRECISION WORK VECTORS INTEGER IWRKV(N+1,2) DOUBLE PRECISION RWRKV(N+1,12) * A LIST OF INERTIA CALCULATIONS INTEGER INTLST(*) * A LIST OF SIGMAS DOUBLE PRECISION SIGLST(*) * THE NUMBER OF SIGMAS AND INERTIA INTEGER INTIDX * PROBLEM TYPE INTEGER PROB * THE LEVEL OF DEBUGGING INTEGER DEBUG * THE LEVEL OF LOOP UNROLLING (IGNORED) INTEGER NROLL * THE DIAGONALS OF THE M MATRIX DOUBLE PRECISION MDIAG(*) * THE OFF-DIAGONALS OF THE M MATRIX DOUBLE PRECISION MSPAR(*) * THE ROWPTRS INTO MSPAR INTEGER MRP(*) * THE COLUMN NUMBERS FOR MSPAR INTEGER MCP(*) * THE DIAGONALS OF THE K MATRIX DOUBLE PRECISION KDIAG(*) * THE OFF-DIAGONALS OF THE K MATRIX DOUBLE PRECISION KSPAR(*) * THE ROWPTRS INTO KSPAR INTEGER KRP(*) * THE COLUMN NUMBERS FOR KSPAR INTEGER KCP(*) * DO WE NEED TO REFORMAT THE SPARSE FORMAT? LOGICAL DOSP * THE FOLLOWING MATRIX VARIABLES ARE TRANSPOSED VERSIONS OF ABOVE * THE M MATRIX DOUBLE PRECISION TM(*) * ROW POINTERS INTO TM INTEGER TMRP(*) * COLUMN NUMBERS FOR TM INTEGER TMCP(*) * THE K MATRIX DOUBLE PRECISION TK(*) * ROW POINTERS INTO TK INTEGER TKRP(*) * COLUMN NUMBERS FOR TK INTEGER TKCP(*) * THE SIZE OF FA INTEGER FASIZE * THE DOUBLE PRECISION ADDRESS OF FA INTEGER FAADDR * THE TOTAL AMOUNT OF MEMORY ALLOCATED INTEGER TMEM * THE B-K STORAGE FACTOR DOUBLE PRECISION BFACT * INTERNAL VARIABLE NAMES * COUNT VARIABLES INTEGER I, J INTEGER CLEN, PLEN, CSIZE, PSIZE INTEGER MCOL, KCOL * THE LEVEL OF LOOP UNROLLING POSSIBLE IN B-K INTEGER UNROLL * THE INERTIA OF THE SYSTEM INTEGER INERT * THE MAXIMUM SIZE THAT FA CAN REACH IN B-K INTEGER MAXSIZ * INTEGER FUNCTIONS INTEGER LOCAL2 EXTERNAL LOCAL2, L2TMON, L2TMOF, FALLOC, BUNCH * 0 MEANS DO FACT, FORW, BACK * 1 MEANS DO FORW, BACK * 2 MEANS DO FACT, FORW * 3 MEANS DO FORW * 4 MEANS DO FACT, BACK * 5 MEANS DO BACK * 6 MEANS ONLY FACTOR IF ((DEBUG.GT.0).OR.(DEBUG.EQ.-1)) THEN CALL L2TMON() ENDIF IF ((INFLAG.EQ.2).OR.(INFLAG.EQ.4)) THEN PRINT *,'ERROR: BUNCH CALLED INCORRECTLY' PRINT *,'REMEDY: CONTACT TESTBED ADMINISTRATOR' STOP * SET UP THE CALL TO THE FACTORIZATION ROUTINE IF NEEDED ELSE IF ((INFLAG.EQ.0).OR.(INFLAG.EQ.6)) THEN * ADJUST TO SOLVE K+SIGMA*M RATHER THAN K-SIGMA*M IF ((PROB.EQ.1).OR.(PROB.EQ.2)) THEN SIGMA = -SIGMA ENDIF * CURRENTLY B-K IS SET TO DO UNROLL=1-6 * DO NOT SET PAST 5 WITHOUT CHANGING RWRKV SIZE * THE LOOP UNROLLING, AS YOU CAN SEE, IS SET BY * USING MAX KEYS, BOTH MATSLV.MSC AND BUNCH.MSC * SHOULD BE RECOMIPILED IF THE LEVEL CURRENTLY * SET (IN THE MAKEFILE) IS CHANGED. UNROLL = 2 * IF THE DATA STRUCTURE IS ALREADY SET UP THEN * GO RIGHT TO FACTORIZATION IF (.NOT.(DOSP)) GOTO 900 * FORM THE VECTOR THAT CONTAINS WHERE EACH COLUMN OF L ENDS CNORECUR DO 68 I = 1, N-1 IF (MRP(I+1).GT.MRP(I)) THEN MCOL = MCP(MRP(I+1)-1) ELSE MCOL = I ENDIF IF (KRP(I+1).GT.KRP(I)) THEN KCOL = KCP(KRP(I+1)-1) ELSE KCOL = I ENDIF FARL(I) = MAX0(MCOL,KCOL) 68 CONTINUE FARL(N) = N MAXSIZ = 0 CLEN = UNROLL PLEN = UNROLL DO 69 I = 1, N, UNROLL PLEN = MAX0(CLEN-UNROLL,PLEN-UNROLL) CLEN = FARL(I)-I+1 DO 70 J = I+1, MIN0(N,I+UNROLL-1) CLEN = MAX0(CLEN,FARL(J)-I+1) 70 CONTINUE CSIZE = ((CLEN*CLEN) + CLEN)/2 PSIZE = ((PLEN*PLEN) + PLEN)/2 MAXSIZ = MAXSIZ + MAX0((CSIZE-PSIZE),0) 69 CONTINUE FASIZE = MAXSIZ * BFACT IF (DEBUG.GT.0) THEN PRINT *,'SIGMA = ',SIGMA PRINT *,'ORIGINAL STORAGE = ',MAXSIZ PRINT *,'STORAGE FACTOR = ',BFACT PRINT *,'TOTAL STORAGE = ',FASIZE ENDIF * NOW ALLOCATE ENOUGH SPACE FOR FA CALL FALLOC(FASIZE,0,FA,TMEM,FALEAD,FAADDR) 900 CONTINUE FASIZE = ABS(FASIZE) ENDIF * CALL MY BUNCH-KAUFMAN ROUTINE CALL BUNCH(N,TK,TKRP,TKCP,TM,TMRP,TMCP, C FA(FALEAD),FARP,FARL,B,X,SIGMA,INFLAG,FASIZE, C RWRKV(1,1),RWRKV(1,2),RWRKV(1,3),RWRKV(1,4), C RWRKV(1,5),RWRKV(1,6),RWRKV(1,7),RWRKV(1,8), C RWRKV(1,8),RWRKV(1,9),RWRKV(1,10),RWRKV(1,11), C RWRKV(1,12),RWRKV(1,12),IWRKV(1,1),IWRKV(1,2), C INERT,DEBUG,MSPAR,MRP,MCP,KSPAR,KRP,KCP,UNROLL) * RE-ADJUST SIGMA IF ((INFLAG.EQ.0).OR.(INFLAG.EQ.6)) THEN * THIS NEGATIVE TELLS BOPER THAT B-K ALLOCATED THIS MEMORY FASIZE = -FASIZE * SET THE INERTIA COUNTS INTIDX = INTIDX + 1 SIGLST(INTIDX) = SIGMA INTLST(INTIDX) = INERT IF ((PROB.EQ.1).OR.(PROB.EQ.2)) THEN SIGMA = -SIGMA SIGLST(INTIDX) = -SIGLST(INTIDX) ENDIF IF ((DEBUG.GT.0).OR.(DEBUG.EQ.-1)) THEN CALL L2TMOF() PRINT *,'TIME FOR FACTORIZATION AND SOLVE = ',LOCAL2() ENDIF ELSE IF ((DEBUG.GT.0).OR.(DEBUG.EQ.-1)) THEN CALL L2TMOF() PRINT *,'TIME FOR SOLVE = ',LOCAL2() ENDIF ENDIF RETURN END * THIS ROUTINE SETS UP THE CALL TO A B-K TYPE FACTORIZATION * AND SOLUTION ROUTINE FOR INDEFINITE MATRICES SUBROUTINE SPSET(N,B,X,SIGMA,INFLAG,FALEAD,FA,FARP, C FARL,IWRKV,RWRKV,INTLST,SIGLST,INTIDX,PROB,DEBUG,NROLL, C MDIAG,MSPAR,MRP,MCP,KDIAG,KSPAR,KRP,KCP, C TK,TKRP,TKCP,TM,TMRP,TMCP,FASIZE,FAADDR,TMEM, C FACTYP,MAXDLY,INSIZE,INPTR,INADDR) * N IS THE ORDER OF THE MATRIX INTEGER N * B IS THE RIGHT HAND SIDE DOUBLE PRECISION B(*) * X IS THE VECTOR BEING SOLVED FOR DOUBLE PRECISION X(*) * SIGMA IS THE SHIFT DOUBLE PRECISION SIGMA * INDICATES WHAT COMBINATION OF FACTORIZATION, BACK AND FORWARD * SOLVE TO DO INTEGER INFLAG * THE LEADING INDEX OF FA INTEGER FALEAD * STORAGE FOR THE FACTORED MATRIX DOUBLE PRECISION FA(*) * FARP IS THE VECTOR OF ROW POINTERS FOR FA INTEGER FARP(*) * FARL IS THE VECTOR OF ROW LENGTHS FOR FA INTEGER FARL(*) * THE INTEGER AND DOUBLE PRECISION WORK VECTORS INTEGER IWRKV(N+1,2) DOUBLE PRECISION RWRKV(N+1,12) * A LIST OF INERTIA CALCULATIONS INTEGER INTLST(*) * A LIST OF SIGMAS DOUBLE PRECISION SIGLST(*) * THE NUMBER OF SIGMAS AND INERTIA INTEGER INTIDX * PROBLEM TYPE INTEGER PROB * THE LEVEL OF DEBUGGING INTEGER DEBUG * THE LEVEL OF LOOP UNROLLING (IGNORED) INTEGER NROLL * THE DIAGONALS OF THE M MATRIX DOUBLE PRECISION MDIAG(*) * THE OFF-DIAGONALS OF THE M MATRIX DOUBLE PRECISION MSPAR(*) * THE ROWPTRS INTO MSPAR INTEGER MRP(*) * THE COLUMN NUMBERS FOR MSPAR INTEGER MCP(*) * THE DIAGONALS OF THE K MATRIX DOUBLE PRECISION KDIAG(*) * THE OFF-DIAGONALS OF THE K MATRIX DOUBLE PRECISION KSPAR(*) * THE ROWPTRS INTO KSPAR INTEGER KRP(*) * THE COLUMN NUMBERS FOR KSPAR INTEGER KCP(*) * THE FOLLOWING MATRIX VARIABLES ARE TRANSPOSED VERSIONS OF ABOVE * THE M MATRIX DOUBLE PRECISION TM(*) * ROW POINTERS INTO TM INTEGER TMRP(*) * COLUMN NUMBERS FOR TM INTEGER TMCP(*) * THE K MATRIX DOUBLE PRECISION TK(*) * ROW POINTERS INTO TK INTEGER TKRP(*) * COLUMN NUMBERS FOR TK INTEGER TKCP(*) * THE SIZE OF FA INTEGER FASIZE * THE DOUBLE PRECISION ADDRESS OF FA INTEGER FAADDR * THE TOTAL AMOUNT OF MEMORY ALLOCATED INTEGER TMEM * THE TYPE OF FACTORIZATION TAKING PLACE INTEGER FACTYP * THE MAXIMUM NUMBER OF DELAYED PIVOTS THAT CAN BE STORED INTEGER MAXDLY * SIZE OF INDICES INTO FACTORED MATRIX (FOR SPARSE FACTOR) INTEGER INSIZE * OFFSET ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INPTR * ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INADDR * INTERNAL VARIABLE NAMES INTEGER UNROLL * THE INERTIA OF THE SYSTEM INTEGER INDEF INTEGER INERT EXTERNAL SPELIM * 0 MEANS DO FACT, FORW, BACK * 1 MEANS DO FORW, BACK * 2 MEANS DO FACT, FORW * 3 MEANS DO FORW * 4 MEANS DO FACT, BACK * 5 MEANS DO BACK * 6 MEANS ONLY FACTOR IF (MOD(INFLAG,2).EQ.0) THEN IF ((PROB.EQ.1).OR.(PROB.EQ.2)) THEN SIGMA = -SIGMA ENDIF ENDIF IF (((PROB.NE.1).AND.(SIGMA.LE.0)).OR.(FACTYP.EQ.3)) THEN INDEF = 0 ELSE INDEF = 1 ENDIF IF (FACTYP.EQ.4) INDEF = 2 CALL SPELIM(N,TK,TKRP,TKCP,TM,TMRP,TMCP, C FA,FARP,FARL,B,X,SIGMA,INFLAG,FASIZE,FAADDR,FALEAD, C RWRKV(1,1),RWRKV(1,2),RWRKV(1,3),RWRKV(1,4), C RWRKV(1,5),RWRKV(1,6),RWRKV(1,7),RWRKV(1,8), C RWRKV(1,9),RWRKV(1,10),RWRKV(1,11),RWRKV(1,12), C IWRKV(1,1),IWRKV(1,2), C INERT,DEBUG,MDIAG,MSPAR,MRP,MCP,KDIAG,KSPAR,KRP,KCP,UNROLL, C INDEF,TMEM,MAXDLY,INSIZE,INPTR,INADDR) IF (MOD(INFLAG,2).EQ.0) THEN * THIS NEGATIVE TELLS BOPER THAT B-K ALLOCATED THIS MEMORY * SET THE INERTIA COUNTS INTIDX = INTIDX + 1 SIGLST(INTIDX) = SIGMA INTLST(INTIDX) = INERT IF ((PROB.EQ.1).OR.(PROB.EQ.2)) THEN SIGMA = -SIGMA SIGLST(INTIDX) = -SIGLST(INTIDX) ENDIF ENDIF RETURN END C$FORTRAN MSHIFT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: MSHIFT.MSC * * AUTHOR: MARK JONES * * PURPOSE: RESPONSIBLE FOR SETTING UP THE SHIFTS AND BOOKKEEPING * * CALLS LANCZS() WHEN IT NEEDS TO * *********************************************************************** SUBROUTINE MSHIFT(N,LDI,IPARAM,RPARAM,R1THET,R1BJ, C R2THET,R2BJ,Y,NEWGES,Q,P,P0,ALPHA,BETA,TBETA, C Z,WORKV1,WORKV2,OTHETA,ONUMT, C TOEIGN,OLDBJ,NUMT, C INTLST,SIGLST,INTIDX, C FA,FARP,FARL,FIWRKV,FRWRKV,KAUX, C KRP,KCP,MAUX,MRP,MCP, C ETA0,ETA1,TAU0,TAU1) * THE ORDER OF THE MATRICES INTEGER N * THE LEADING INDEX OF Y INTEGER LDI * IPARAM IS A SET OF INTEGER PARAMETERS FOR LANCZOS INTEGER IPARAM(*) * RPARAM IS A SET OF DOUBLE PRECISION PARAMETERS FOR LANCZOS DOUBLE PRECISION RPARAM(*) * ARRAYS TO STORE EIGENVALUES FOR LANCZOS RUNS DOUBLE PRECISION R1THET(*), R2THET(*) * BJ'S ARE ARRAYS TO STORE ERROR BOUNDS ON EIGENVALUES DOUBLE PRECISION R1BJ(*), R2BJ(*) * Y IS THE ARRAY OF EIGENVECTORS DOUBLE PRECISION Y(LDI,*) * THE NEW GUESS VECTOR DOUBLE PRECISION NEWGES(*) * Q IS THE ARRAY OF LANCZOS VECTORS DOUBLE PRECISION Q(*) * P IS THE DIRECTION VECTOR AT STEPS J, J-1 DOUBLE PRECISION P(*), P0(*) * ALPHA AND BETA ARE THE ARRAY OF THE TRIDIAGONAL MATRIX, T DOUBLE PRECISION ALPHA(*), BETA(*) * TBETA IS THE SQUARE OF BETA DOUBLE PRECISION TBETA(*) * STORAGE FOR EIGENVECTORS OF T DOUBLE PRECISION Z(*) * OTHER WORK VECTORS DOUBLE PRECISION WORKV1(*), WORKV2(*) * OTHETA IS AN ARRAY OF EIGENVALUES DOUBLE PRECISION OTHETA(*) * ONUMT IS THE ARRAY OF EIGENVECTORS INTEGER ONUMT(*) * OLD NUMBER OF EIGEN PAIRS GIVEN TO US INTEGER TOEIGN * OLDBJ IS AN ARRAY OF OLD ERROR BOUNDS DOUBLE PRECISION OLDBJ(*) * WORK VECTOR FOR LANCZOS INTEGER NUMT(*) * A LIST OF INERTIA CALCULATIONS INTEGER INTLST(*) * A LIST OF SIGMAS DOUBLE PRECISION SIGLST(*) * THE NUMBER OF SIGMAS AND INERTIA INTEGER INTIDX * STORAGE FOR THE FACTORED MATRIX DOUBLE PRECISION FA(*) * FARP IS THE VECTOR OF ROW POINTERS FOR FA INTEGER FARP(*) * FARL IS THE VECTOR OF ROW LENGTHS FOR FA INTEGER FARL(*) * WORK VECTORS FOR FACTORIZATION DOUBLE PRECISION FRWRKV(*) INTEGER FIWRKV(*) * THE STIFFNESS MATRIX DOUBLE PRECISION KAUX(*) * A VECTOR ASSOCIATED WITH KAUX INTEGER KRP(*) * A VECTOR ASSOCIATED WITH KAUX INTEGER KCP(*) * THE MASS MATRIX DOUBLE PRECISION MAUX(*) * A VECTOR ASSOCIATED WITH MAUX INTEGER MRP(*) * A VECTOR ASSOCIATED WITH MAUX INTEGER MCP(*) * USED TO COMPUTE PRO RECURRENCE DOUBLE PRECISION ETA0(*), ETA1(*) * USED BY LANCZS TO COMPUTE EXTERNAL TAU RECURRENCE DOUBLE PRECISION TAU0(*), TAU1(*) * THE FOLLOWING VARIABLES ARE INTERNAL VARIABLES * A PRIVATE VARIABLE THAT CONTAINS THE SAME THING AS TOEIGN INTEGER OEIGNM * THE NORMS FOR K AND M DOUBLE PRECISION KNORM, MNORM * THE MAXIMUM NUMBER OF TOTAL LANCZOS STEPS TO TAKE INTEGER LANMAX * THE LEFT AND RIGHT SHIFTS DOUBLE PRECISION LFTVAL, RGTVAL * INDICATES WHETHER LEFT AND RIGHT SHIFTS EXIST LOGICAL NWRGHT, NWLEFT * ARE WE FINISHED? LOGICAL DONE * THE TOTAL NUMBER OF STEPS TAKEN TO DATE INTEGER TOTSTP * IF BOUNDARIES, WHAT STATE ARE WE IN? INTEGER TSTATE * WHETHER A RIGHT (1) OR LEFT (2) SHIFT IS BEING WORKED ON INTEGER RUN * THE NUMBER OF VALUES IN R1THET OR R2THET INTEGER R1LEN, R2LEN * IS THE CURRENT SIGMA TO BE WORKED ON? LOGICAL OKSIG * THE NUMBER OF EIGENVALUES BEING SOUGHT INTEGER NMSGT * THE ORIGINAL NUMBER OF EIGENVALUES BEING SOUGHT INTEGER ONMSGT * A COUNT VARIABLE INTEGER I, J * DOES AN INITIAL GUESS EXIST LOGICAL INIGSS * THE ORIGINAL SIGMA THAT WAS BEING SEARCHED AROUND DOUBLE PRECISION OSIGMA * HAS CHKFIN OKAYED THE EIGENVALUES INTEGER OKAY EXTERNAL TRANSM, GETNRM, BSTATE, RNDVEC, LANCZS, NWSLVE EXTERNAL SPSET, CPYVEC, CHKFIN, NWSHFT OEIGNM = TOEIGN IF ((IPARAM(9).EQ.0).AND. C (((RPARAM(1).NE.0.0D0).AND.(IPARAM(14).EQ.0)).OR. C (((RPARAM(5)+RPARAM(6))/2.0D0.NE.0.0D0).AND. C (IPARAM(14).EQ.1)))) THEN SIGLST(1) = 0.0D0 INTLST(1) = 0 INTIDX = 1 ELSE INTIDX = 0 ENDIF * THIS IS FOR THE VIBRATION PROBLEM WHEN WE HAVE A SPD K IF (IPARAM(9).EQ.3) THEN IPARAM(9) = 0 IPARAM(19) = 1 ELSE IPARAM(19) = 0 ENDIF * COMPUTE THE TRANSPOSES OF K AND M CALL TRANSM(IPARAM(1),KAUX,KAUX(IPARAM(1)+1),KRP,KCP, C KAUX(IPARAM(1)+KRP(IPARAM(1)+1)),KRP(IPARAM(1)+2), C KCP(KRP(IPARAM(1)+1)+1),WORKV1,IPARAM(8)) CALL TRANSM(IPARAM(1),MAUX,MAUX(IPARAM(1)+1),MRP,MCP, C MAUX(IPARAM(1)+MRP(IPARAM(1)+1)),MRP(IPARAM(1)+2), C MCP(MRP(IPARAM(1)+1)+1),WORKV1,IPARAM(8)) MNORM = 0.0D0 KNORM = 0.0D0 * GET THE NORMS OF THE K AND M MATRICES FOR SHIFT CALCULATIONS CALL GETNRM(IPARAM(1),WORKV1,WORKV2,KNORM,MNORM, C KAUX,KAUX(IPARAM(1)+1),KRP,KCP,KAUX(IPARAM(1)+ C KRP(IPARAM(1)+1)),KRP(IPARAM(1)+2),KCP(KRP(IPARAM(1)+1)+1), C MAUX,MAUX(IPARAM(1)+1),MRP,MCP,MAUX(IPARAM(1)+ C MRP(IPARAM(1)+1)),MRP(IPARAM(1)+2),MCP(MRP(IPARAM(1)+1)+1)) * FIGURE OUT THE SHIFT TO USE DEPENDING ON WHETHER WE ARE * SEARCHING IN A RANGE OR NOT IF (IPARAM(14).EQ.0) THEN OSIGMA = RPARAM(1) TSTATE = 0 ELSE OSIGMA = (RPARAM(5)+RPARAM(6))/2.0D0 IF ((OSIGMA.NE.0.0D0).AND.(IPARAM(9).EQ.2)) THEN IPARAM(9) = 1 ELSE IF ((OSIGMA.EQ.0.0D0).AND.(IPARAM(9).EQ.1)) THEN IPARAM(9) = 2 ENDIF RPARAM(1) = OSIGMA TSTATE = -1 ENDIF * CHANGE THE TRANSFORMATION TYPE, IF NEEDED IF (IPARAM(9).EQ.1) THEN * WE ARE WORKING ON TRANSFORMATION D, SO NO ZERO SHIFT IF (RPARAM(1).EQ.0.0D0) THEN PRINT *,'WARNING: CANNOT USE ZERO SHIFT FOR THIS BUCKLING', C' TRANSFORMATION' PRINT *,'SWITCHING TO TRANSFORMATION 2' IPARAM(9) = 2 ENDIF ELSE IF (IPARAM(9).EQ.2) THEN * WE ARE WORKING ON TRANSFORMATION E, SO NO NON-ZERO SHIFT IF (RPARAM(1).NE.0.0D0) THEN PRINT *,'WARNING: CANNOT USE NON-ZERO SHIFT FOR THIS', C' BUCKLING TRANSFORMATION' PRINT *,'SWITCHING TO TRANSFORMATION 1' IPARAM(9) = 1 ENDIF ENDIF * SET VARIABLES TO THE CORRECT PARAMETERS LANMAX = IPARAM(4) * INITIALIZE VALUES IF (IPARAM(29).EQ.0) THEN INIGSS = .FALSE. ELSE INIGSS = .TRUE. ENDIF LFTVAL = RPARAM(1) RGTVAL = RPARAM(1) DONE = .FALSE. NWLEFT = .FALSE. NWRGHT = .TRUE. NMSGT = IPARAM(3) ONMSGT = NMSGT DO 1 I = TOEIGN+1, IPARAM(2) ONUMT(I) = 0 1 CONTINUE TOTSTP = 0 R1LEN = 0 R2LEN = 0 10 CONTINUE IF (DONE) THEN GOTO 20 ELSE * SET UP CALL TO LANCZOS RUN = 1 30 CONTINUE CALL BSTATE(TSTATE,NWLEFT,NWRGHT,LFTVAL,RGTVAL,IPARAM(6), C RPARAM(5),RPARAM(6),RUN) IF (RUN.EQ.1) THEN RPARAM(1) = RGTVAL OKSIG = NWRGHT ELSE RPARAM(1) = LFTVAL OKSIG = NWLEFT ENDIF IF (OKSIG) THEN IF (.NOT.INIGSS) THEN CALL RNDVEC(IPARAM(1),NEWGES,INTIDX) ENDIF IF (INIGSS) THEN INIGSS = .FALSE. ENDIF IPARAM(3) = NMSGT - OEIGNM IPARAM(6) = -1 * SET THE MAXIMUM NUMBER OF STEPS THAT MAY BE * TAKEN IN THIS RUN IPARAM(4) = MIN0(IPARAM(13),LANMAX-TOTSTP) IF (IPARAM(8).GT.0) THEN PRINT *,'MAX STEPS THIS RUN = ',IPARAM(4) ENDIF IF (RUN.EQ.1) THEN CALL LANCZS(IPARAM(1),IPARAM(16),IPARAM,RPARAM, C R1THET,R1BJ,Y,Q,P,P0,ALPHA,BETA,TBETA,Z, C WORKV1,WORKV2,OTHETA, C ONUMT,OEIGNM,NUMT, C NEWGES,FA,FARP,FARL,FIWRKV,FRWRKV, C INTLST,SIGLST,INTIDX, C KAUX,KRP,KCP, C MAUX,MRP,MCP, C ETA0,ETA1,TSTATE,OLDBJ,TAU0,TAU1) ELSE CALL LANCZS(IPARAM(1),IPARAM(16),IPARAM,RPARAM, C R2THET,R2BJ,Y,Q,P,P0,ALPHA,BETA,TBETA,Z, C WORKV1,WORKV2,OTHETA, C ONUMT,OEIGNM,NUMT, C NEWGES,FA,FARP,FARL,FIWRKV,FRWRKV, C INTLST,SIGLST,INTIDX, C KAUX,KRP,KCP, C MAUX,MRP,MCP, C ETA0,ETA1,TSTATE,OLDBJ,TAU0,TAU1) ENDIF IF ((IPARAM(4).EQ.0).AND.(IPARAM(6).EQ.-2)) THEN PRINT *,'ERROR: NO SPACE FOR EIGENVECTORS' PRINT *,'REMEDY: INCREASE YSTO' IPARAM(6) = -2 GOTO 20 ENDIF * SAVE THE THETA AND BJ FROM THE RUNS IF (RUN.EQ.1) THEN * MOVE FOUND EIGENPAIRS TO OLD STUFF DO 50 J = 1, IPARAM(4) IF (R1BJ(J).GE.0.0D0) THEN OEIGNM = OEIGNM + 1 IF (OEIGNM.GT.IPARAM(2)) THEN PRINT *,'ERROR: NO SPACE FOR EIGENVECTORS' PRINT *,'REMEDY: INCREASE YSTO' OEIGNM = IPARAM(2) IPARAM(6) = -2 GOTO 20 ENDIF OTHETA(OEIGNM) = R1THET(J) OLDBJ(OEIGNM) = R1BJ(J) ONUMT(OEIGNM) = NUMT(J) * IF USING A TRANSFORMATION THAT REQUIRES IT, * RECOVER EIGENVECTORS IF (IPARAM(9).EQ.2) THEN IF (IPARAM(24).LT.2) THEN CALL NWSLVE(IPARAM(1), C Y(1,ONUMT(OEIGNM)), C Y(1,ONUMT(OEIGNM)),RPARAM(1),5, C IPARAM(11),FA,FARP, C FARL,INTLST,SIGLST, C INTIDX,IPARAM(9),IPARAM(8), C IPARAM(18),MAUX,MAUX(IPARAM(1)+1), C MRP,MCP,KAUX,KAUX(IPARAM(1)+1), C KRP,KCP,IPARAM(26),IPARAM(23),IPARAM(12)) ELSE CALL SPSET(IPARAM(1), C Y(1,ONUMT(OEIGNM)),Y(1,ONUMT(OEIGNM)),RPARAM(1), C 5,IPARAM(11),FA,FARP, C FARL,FIWRKV,FRWRKV,INTLST,SIGLST,INTIDX,IPARAM(9), C IPARAM(8),IPARAM(18),MAUX,MAUX(IPARAM(1)+1),MRP,MCP,KAUX, C KAUX(IPARAM(1)+1),KRP,KCP, C KAUX(IPARAM(1)+KRP(IPARAM(1)+1)),KRP(IPARAM(1)+2), C KCP(KRP(IPARAM(1)+1)+1),MAUX(IPARAM(1)+MRP(IPARAM(1)+1)), C MRP(IPARAM(1)+2),MCP(MRP(IPARAM(1)+1)+1), C IPARAM(26),IPARAM(23),IPARAM(12),IPARAM(24),IPARAM(20), C IPARAM(21),IPARAM(22),IPARAM(28)) ENDIF ENDIF ENDIF 50 CONTINUE R1LEN = IPARAM(4) ELSE * MOVE FOUND EIGENPAIRS TO OLD STUFF DO 51 J = 1, IPARAM(4) IF (R2BJ(J).GE.0.0D0) THEN OEIGNM = OEIGNM + 1 IF (OEIGNM.GT.IPARAM(2)) THEN PRINT *,'ERROR: NO SPACE FOR EIGENVECTORS' PRINT *,'REMEDY: INCREASE YSTO' OEIGNM = IPARAM(2) IPARAM(6) = -2 GOTO 20 ENDIF OTHETA(OEIGNM) = R2THET(J) OLDBJ(OEIGNM) = R2BJ(J) ONUMT(OEIGNM) = NUMT(J) ENDIF 51 CONTINUE R2LEN = IPARAM(4) ENDIF * UPDATE THE NUMBER OF STEPS TOTSTP = TOTSTP + IPARAM(4) ELSE IF (RUN.EQ.1) THEN R1LEN = 0 ELSE R2LEN = 0 ENDIF ENDIF * FOUND ENOUGH YET? IF ((OEIGNM.GE.NMSGT).AND.(IPARAM(14).EQ.0)) THEN IPARAM(6) = 0 IF (RUN.EQ.1) THEN NWLEFT = .FALSE. ENDIF GOTO 40 ENDIF IF ((TOTSTP.GE.LANMAX).AND.(IPARAM(14).EQ.0)) THEN IF (RUN.EQ.1) THEN NWLEFT = .FALSE. ENDIF GOTO 40 ENDIF IF (RUN.LT.2) THEN RUN = RUN + 1 GOTO 30 ENDIF 40 CONTINUE * MAKE SURE THAT THE RIGHT TRANSFORMATION IS USED * IF WE HAVE SHIFTED IF (IPARAM(9).EQ.2) THEN IPARAM(9) = 1 ENDIF * CHECK HERE FOR MISSED EIGENVALUES * P IS USED AS A WORK VECTOR HERE CALL CHKFIN(IPARAM(1),OEIGNM,OTHETA,OLDBJ,R1LEN,R1THET, C R1BJ,R2LEN,R2THET,R2BJ,ONMSGT,OSIGMA,LFTVAL,RGTVAL, C NWLEFT,NWRGHT,IPARAM(8),KNORM,MNORM,RPARAM(2), C RPARAM(3),IPARAM(5),NMSGT,WORKV1,WORKV2, C P,INTLST,SIGLST,INTIDX, C IPARAM(11),FA,FARP,FARL,FIWRKV,FRWRKV, C IPARAM(9),IPARAM(18),KAUX,KRP,KCP, C MAUX,MRP,MCP,IPARAM(26),IPARAM(23),IPARAM(12), C IPARAM(15),IPARAM(17),IPARAM(24),IPARAM(25),OKAY,TSTATE, C IPARAM(14),RPARAM(5),RPARAM(6),RPARAM(7), C IPARAM(20),IPARAM(21),IPARAM(22),IPARAM(28)) IF (OKAY.EQ.-1) THEN IPARAM(6) = -1 GOTO 20 ELSE IF (OKAY.LE.0) THEN IPARAM(6) = 0 GOTO 20 ELSE IF (TOTSTP.GE.LANMAX) THEN * TAKEN TOO MANY STEPS YET? DONE = .TRUE. IPARAM(6) = -1 GOTO 20 ELSE IF (OKAY.EQ.1) THEN * FIND NEW SHIFTS CALL NWSHFT(OEIGNM,OTHETA,OLDBJ,R1LEN,R1THET,R1BJ, C R2LEN,R2THET,R2BJ,LFTVAL,RGTVAL,NWLEFT,NWRGHT, C IPARAM(8),KNORM,MNORM,RPARAM(2),RPARAM(3),OSIGMA) ENDIF IF (IPARAM(8).GE.1) THEN PRINT *,'SHIFT (LR)',NWLEFT,LFTVAL,NWRGHT,RGTVAL ENDIF IPARAM(6) = 0 * NO SHIFTS LEFT? IF ((.NOT.NWRGHT).AND.(.NOT.NWLEFT)) THEN DONE = .TRUE. IPARAM(6) = -1 ENDIF ENDIF GOTO 10 20 CONTINUE IPARAM(7) = OEIGNM IPARAM(4) = TOTSTP TOEIGN = OEIGNM RETURN END C$FORTRAN NEWTON *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: NEWTON.MSC * * AUTHOR: MARK JONES * * PURPOSE: FINDS AN EIGENVALUE BETWEEN LEFT AND RIGHT USING * * NEWTON'S METHOD * *********************************************************************** SUBROUTINE NEWTON(J,ALF,BET2,THET,BJ,EPS,LEFT,RIGHT,DEBUG, C IND,HUGE) * J IS THE ORDER OF T(J) INTEGER J * ALF IS THE DIAGONAL OF T(J) DOUBLE PRECISION ALF(J) * BET2 IS THE SQUARE OF THE OFF-DIAGONAL OF T(J) DOUBLE PRECISION BET2(J) * THE RITZ VALUE DOUBLE PRECISION THET * BJ IS THE ERROR BOUND ON THET DOUBLE PRECISION BJ * EPS IS THE MACHINE PRECISION DOUBLE PRECISION EPS * BOUNDS FOR NEWTON TO STAY IN DOUBLE PRECISION LEFT, RIGHT * DEBUGGING ON/OFF INTEGER DEBUG * THE INDEX OF THE EIGENVALUE BEING SOUGHT INTEGER IND * THE LARGEST DOUBLE PRECISION NUMBER DOUBLE PRECISION HUGE * THE FOLLOWING ARE INTERNAL VARIABLES * VARIABLES USED IN FORMULA, SEE PARLETT DOUBLE PRECISION H, P, SUM, DELTA, OLDTHT, PI * COUNT VARIABLE INTEGER K * A TEMPORARY VARIABLE DOUBLE PRECISION TVAL * LOOP VARIABLE LOGICAL START * DIFFERENCE BETWEEN OLD AND NEW VALUES DOUBLE PRECISION DIFF, ODIFF EXTERNAL BISEC1 * CHECK TO ENSURE THAT THE INTERVAL IS CORRECT * IF ((IND.EQ.1).OR.(IND.EQ.J)) THEN CALL BISEC1(J,ALF,BET2,LEFT,RIGHT,EPS,IND,DEBUG) THET = (LEFT+RIGHT)/2.0D0 * ENDIF IF (THET+((RIGHT-LEFT)/8.0D0).EQ.THET) THEN IF (DEBUG.GT.0) THEN PRINT *,'BISECT CONVERGED TO ',THET ENDIF GOTO 60 ENDIF * FIND EIGENVALUE START = .TRUE. 10 CONTINUE OLDTHT = THET H = 0.0D0 P = 0.0D0 SUM = 0.0D0 DO 20 K = 1, J DELTA = ALF(K) - THET - H IF (DELTA .EQ. 0.0D0) THEN DELTA = EPS*BET2(K+1) ENDIF P = (1.0D0+H*P)/DELTA H = BET2(K+1)/DELTA SUM = SUM + P 20 CONTINUE THET = THET + (1.0D0/SUM) IF ((THET.GT.RIGHT).OR.(THET.LT.LEFT)) THEN IF (DEBUG.GT.0) THEN PRINT *,'OLD LR: ',LEFT,RIGHT PRINT *,'CALLING BISECT OLD THETA = ',THET ENDIF CALL BISEC1(J,ALF,BET2,LEFT,RIGHT,EPS,IND,DEBUG) THET = (LEFT+RIGHT)/2.0D0 IF (THET+((RIGHT-LEFT)/16.0D0).EQ.THET) THEN IF (DEBUG.GT.0) THEN PRINT *,'BISECT CONVERGED TO ',THET ENDIF GOTO 60 ENDIF IF (DEBUG.GT.0) THEN PRINT *,'CALLED BISECT NEW THETA = ',THET ENDIF START = .TRUE. * LEFT = LEFT - 2.0D0*ABS(LEFT)*EPS * RIGHT = RIGHT + 2.0D0*ABS(RIGHT)*EPS GOTO 10 ENDIF ODIFF = DIFF DIFF = (THET-OLDTHT) IF (((ABS(ODIFF).LE.ABS(DIFF)).AND.(.NOT.START)).OR. C (THET+(DIFF/2.0D0).EQ.THET)) GOTO 60 START = .FALSE. GOTO 10 60 CONTINUE * FIND ERROR BOUND PI = 1.0D0 H = 0.0D0 P = 0.0D0 DO 30 K = J, 2, -1 DELTA = ALF(K) - THET - H TVAL = DELTA*DELTA/BET2(K) IF (TVAL.GT.1.0D0) THEN IF (ABS(HUGE/TVAL).LT.ABS(PI)) THEN BJ = 0.0D0 RETURN ENDIF ENDIF PI = PI*TVAL IF (DELTA .EQ. 0.0D0) THEN DELTA = EPS*(BET2(K)+ALF(K)*ALF(K)) ENDIF P = (1.0D0+H*P)/DELTA H = BET2(K)/DELTA 30 CONTINUE BJ = SQRT(1.0D0/((1.0D0 + H*P)*PI)) RETURN END C$FORTRAN NUMLES *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: NUMLES.MSC * * AUTHOR: MARK JONES * * PURPOSE: FIND THE NUMBER OF EIGENVALUES LESS THAN PROBE * *********************************************************************** INTEGER FUNCTION NUMLES(ALF,BET2,PROBE,J,INC,EPS) * ALF IS THE DIAGONAL OF T(J) DOUBLE PRECISION ALF(*) * BET2 IS THE SQUARE OF THE OFF-DIAGONAL OF T(J) DOUBLE PRECISION BET2(*) * PROBE IS THE THE VALUE BEING CHECKED DOUBLE PRECISION PROBE * J IS THE ORDER OF T(J) INTEGER J * INC INDICATES WHICH END OF THE SPECTRUM IS BEING CHECKED INTEGER INC * MACHINE EPSILON DOUBLE PRECISION EPS * THE FOLLOWING ARE INTERNAL VARIABLES * A COUNT VARIABLE INTEGER I * CURRENT PIVOT VALUE DOUBLE PRECISION DELTA NUMLES = 0 DELTA = 1.0D0 BET2(1) = 0.0D0 DO 10 I = 1, J DELTA = ALF(I) - PROBE - (BET2(I)/DELTA) IF (DELTA.LT.0.0D0) THEN NUMLES = NUMLES + 1 ELSE IF (DELTA.EQ.0.0D0) THEN DELTA = EPS*BET2(I+1) * PRINT *,'GOT A ZERO' ENDIF 10 CONTINUE IF (INC.EQ.-1) THEN NUMLES = J - NUMLES ENDIF RETURN END C$FORTRAN PREDCT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: PREDCT.MSC * * AUTHOR: MARK JONES * * PURPOSE: PREDICT HOW MANY STEPS TO CONVERGE TO SOME EIGENVALUES* *********************************************************************** SUBROUTINE PREDCT(J,MAXN,THETA,BJ,DEBUG,GTOL,OSIGMA, C EPS,HUGE,PROB,RESULT,LDI,C,ETHETA,ATHETA,ALPHA,BETA,BETA2) DOUBLE PRECISION EPS, HUGE * THE SIZE OF T INTEGER J * THE SIZE OF THE SYSTEM INTEGER MAXN * THE EIGENVALUES OF T DOUBLE PRECISION THETA(*) * THE ERROR BOUNDS ON THETA DOUBLE PRECISION BJ(*) * LEVEL OF DEBUGGING OUTPUT INTEGER DEBUG * ERROR TOLERANCE DOUBLE PRECISION GTOL * THE OLD SIGMA DOUBLE PRECISION OSIGMA * PROB TYPE INTEGER PROB * RESULT FROM PREDCT INTEGER RESULT * LEADING INDEX OF THE WORK SPACE INTEGER LDI * THE WORKSPACE DOUBLE PRECISION C(LDI,*) * WORK VECTORS DOUBLE PRECISION ATHETA(*), ETHETA(*), ALPHA(*) DOUBLE PRECISION BETA(*), BETA2(*) * SOME INTERNAL VARIABLES * WORK VECTORS DOUBLE PRECISION NTHETA, NBJ, LEFT, RIGHT INTEGER N,NUMS,INC * COUNTER VARIABLES INTEGER I INTEGER K * THE NEW SIGMA DOUBLE PRECISION NSIGMA * ??? INTEGER JMAX, IMAX, ITOOK, NOFF, I2TOOK, IPROB * THE NUMBER OF ATHETA'S INTEGER ACOUNT * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION EIGTRA, RELERR EXTERNAL EIGTRA, RELERR, UPDTC, CONA, NEWTON IF (J+40.GE.LDI-5) THEN RESULT = 0 RETURN ENDIF N = J+40 NUMS = J + 20 INC = 1 CALL CONA(J,N,MAXN,ETHETA,THETA,BJ,ATHETA,ACOUNT,OSIGMA,GTOL, C JMAX,PROB,NSIGMA) DO 20 I = 1, NUMS CALL UPDTC(LDI,I,N,MAXN,ETHETA,C,ALPHA,BETA,BETA2, C .FALSE.,IMAX,NUMS,EPS) IF (I.GE.NUMS) GOTO 21 20 CONTINUE 21 CONTINUE ITOOK = 10000 LEFT = ETHETA(JMAX)-0.05D0*ETHETA(JMAX) RIGHT = ETHETA(JMAX)+0.05D0*ETHETA(JMAX) NTHETA = ETHETA(JMAX) NOFF = 0 IF (NTHETA.GT.0.0D0) THEN DO 25 I = 1, N IF (ETHETA(I).GT.NTHETA) THEN NOFF = NOFF + 1 ENDIF 25 CONTINUE ELSE DO 26 I = 1, N IF (ETHETA(I).LT.NTHETA) THEN NOFF = NOFF + 1 ENDIF 26 CONTINUE ENDIF IF (DEBUG.GT.1) THEN PRINT *,'GUESS = ',NTHETA,EIGTRA(NTHETA,OSIGMA,PROB),NOFF ENDIF DO 30 I = J+1, NUMS, INC IF (NTHETA.GT.0.0D0) THEN K = I - NOFF ELSE K = NOFF + 1 ENDIF CALL NEWTON(I,ALPHA,BETA2,NTHETA,NBJ,EPS,LEFT,RIGHT, C DEBUG,K,HUGE) NBJ = NBJ * BETA(I+1) LEFT = NTHETA-MIN(0.05D0*NTHETA,NBJ) RIGHT = NTHETA+MIN(0.05D0*NTHETA,NBJ) IF (DEBUG.GT.1) THEN PRINT *,'TSTEP ',I,NTHETA,NBJ,EIGTRA(NTHETA,OSIGMA,PROB) ENDIF IF (RELERR(NTHETA,NBJ,OSIGMA,PROB).LT.GTOL) THEN ITOOK = I-J IF (DEBUG.GT.0) THEN PRINT *,'TOOK ',I-J,' STEPS TO GET 1 MORE' ENDIF GOTO 31 ENDIF 30 CONTINUE 31 CONTINUE NUMS = MIN(10,ACOUNT) DO 50 I = 1, NUMS CALL UPDTC(LDI,I,ACOUNT,MAXN,ATHETA,C,ALPHA,BETA,BETA2, C .TRUE.,IMAX,NUMS,EPS) IF (I.GE.NUMS) GOTO 51 50 CONTINUE 51 CONTINUE IF (DEBUG.GT.0) THEN PRINT *,'BEGINNING OF NEW',ACOUNT,IMAX ENDIF I2TOOK = 10000 LEFT = ATHETA(IMAX)-0.05D0*ATHETA(IMAX) RIGHT = ATHETA(IMAX)+0.05D0*ATHETA(IMAX) NTHETA = ATHETA(IMAX) IF (PROB.EQ.2) THEN IPROB = 1 ELSE IPROB = PROB ENDIF IF (DEBUG.GT.1) THEN PRINT *,'NEW GUESS ',NTHETA,EIGTRA(NTHETA,NSIGMA,IPROB) ENDIF DO 60 I = 1, NUMS, INC IF (NTHETA.GT.0.0D0) THEN K = I ELSE K = 1 ENDIF CALL NEWTON(I,ALPHA,BETA2,NTHETA,NBJ,EPS,LEFT,RIGHT, C DEBUG,K,HUGE) NBJ = NBJ * BETA(I+1) LEFT = NTHETA-MIN(0.05D0*NTHETA,NBJ) RIGHT = NTHETA+MIN(0.05D0*NTHETA,NBJ) IF (DEBUG.GT.0) THEN PRINT *,'GOT ',NTHETA,NBJ,RELERR(NTHETA,NBJ,NSIGMA, C IPROB) ENDIF IF (RELERR(NTHETA,NBJ,NSIGMA,IPROB).LT.GTOL) THEN I2TOOK = I IF (DEBUG.GT.0) THEN PRINT *,'NEW TOOK ',I,' STEPS TO GET 1 MORE' ENDIF GOTO 61 ENDIF 60 CONTINUE 61 CONTINUE RESULT = ITOOK - I2TOOK RETURN END SUBROUTINE CONA(J,N,MAXN,ETHETA,THETA,BJ,ATHETA,ACOUNT,OSIGMA, C GTOL,JMAX,PROB,SIGMA) INTEGER J,N,MAXN, ACOUNT, JMAX, PROB DOUBLE PRECISION ETHETA(*), THETA(*),BJ(*), ATHETA(*), C OSIGMA, GTOL, SIGMA * INTERNAL VARS INTEGER I, COUNT, NUML, NUMR DOUBLE PRECISION ADD, RMIN1, RMIN2, LMIN1, LMIN2, MIDDLE, C LTHETA, RTHETA * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION RELERR, EIGTRA EXTERNAL RELERR, EIGTRA COUNT = 0 ACOUNT = 0 IF (PROB.EQ.1.0D0) THEN MIDDLE = 1.0D0 SIGMA = 1.0D0 ELSE MIDDLE = 0.0D0 SIGMA = 0.0D0 ENDIF NUML = 0 NUMR = 0 DO 10 I = 1, J IF (RELERR(THETA(I),BJ(I),OSIGMA,PROB).GT.GTOL) THEN IF (THETA(I).LT.MIDDLE) THEN IF (NUML.EQ.0) THEN NUML = 1 LMIN1 = THETA(I) ELSE IF (NUML.EQ.1) THEN NUML = 2 IF (MIDDLE-THETA(I).LT.MIDDLE-LMIN1) THEN LMIN1 = THETA(I) ELSE LMIN2 = THETA(I) ENDIF ELSE NUML = NUML + 1 IF (MIDDLE-THETA(I).LT.MIDDLE-LMIN1) THEN LMIN2 = LMIN1 LMIN1 = THETA(I) ELSE IF (MIDDLE-THETA(I).LT.MIDDLE-LMIN2) THEN LMIN2 = THETA(I) ENDIF ENDIF ELSE IF (NUMR.EQ.0) THEN NUMR = 1 RMIN1 = THETA(I) ELSE IF (NUMR.EQ.1) THEN NUMR = 2 IF (MIDDLE+THETA(I).LT.MIDDLE+RMIN1) THEN RMIN1 = THETA(I) ELSE RMIN2 = THETA(I) ENDIF ELSE NUMR = NUMR + 1 IF (MIDDLE+THETA(I).LT.MIDDLE+RMIN1) THEN RMIN2 = RMIN1 RMIN1 = THETA(I) ELSE IF (MIDDLE+THETA(I).LT.MIDDLE+RMIN2) THEN RMIN2 = THETA(I) ENDIF ENDIF ENDIF ENDIF IF (ABS(BJ(I)).LT.ABS(THETA(I))*0.05D0) THEN COUNT = COUNT + 1 ETHETA(COUNT) = THETA(I) IF (RELERR(THETA(I),BJ(I),OSIGMA,PROB).GT.GTOL) THEN ACOUNT = ACOUNT + 1 ATHETA(ACOUNT) = THETA(I) IF (ABS(MIDDLE-THETA(I)).GT.ABS(MIDDLE-SIGMA)) THEN SIGMA = THETA(I) JMAX = COUNT ENDIF ENDIF ELSE IF ((RELERR(THETA(I),BJ(I),OSIGMA,PROB).GT.GTOL) C .AND.(ABS(MIDDLE-THETA(I)).GT.ABS(MIDDLE-SIGMA))) THEN SIGMA = THETA(I) JMAX = COUNT ENDIF IF (ABS(BJ(I)).LT.ABS(THETA(I))*0.10D0) THEN COUNT = COUNT + 1 ACOUNT = ACOUNT + 1 ETHETA(COUNT) = THETA(I) + 0.025*ABS(THETA(I)) ATHETA(ACOUNT) = ETHETA(COUNT) COUNT = COUNT + 1 ACOUNT = ACOUNT + 1 ETHETA(COUNT) = THETA(I) - 0.025*ABS(THETA(I)) ATHETA(ACOUNT) = ETHETA(COUNT) ELSE COUNT = COUNT + 1 ACOUNT = ACOUNT + 1 ETHETA(COUNT) = THETA(I) + 0.0125*ABS(THETA(I)) ATHETA(ACOUNT) = ETHETA(COUNT) COUNT = COUNT + 1 ACOUNT = ACOUNT + 1 ETHETA(COUNT) = THETA(I) ATHETA(ACOUNT) = ETHETA(COUNT) COUNT = COUNT + 1 ACOUNT = ACOUNT + 1 ETHETA(COUNT) = THETA(I) - 0.0125*ABS(THETA(I)) ATHETA(ACOUNT) = ETHETA(COUNT) ENDIF ENDIF 10 CONTINUE * PRINT *,'SMALL ',NUML,NUMR,LMIN1,LMIN2,RMIN1,RMIN2 IF (N-1.GT.COUNT) THEN IF ((NUML.GE.4).AND.(NUMR.GE.4)) THEN LTHETA = MIDDLE + (LMIN1-MIDDLE) / 4.0D0 ADD = (LMIN1 - LMIN2)/((N-COUNT)/2) DO 20 I = COUNT+1, N-((N-COUNT)/2) ETHETA(I) = LMIN2 + ADD*(I-COUNT) ACOUNT = ACOUNT + 1 ATHETA(ACOUNT) = ETHETA(I) 20 CONTINUE COUNT = COUNT + (N-COUNT)/2 RTHETA = MIDDLE + (RMIN1-MIDDLE) / 4.0D0 ADD = (RMIN1 - RMIN2)/(N-COUNT) DO 21 I = COUNT+1, N ETHETA(I) = RMIN2 + ADD*(I-COUNT) ACOUNT = ACOUNT + 1 ATHETA(ACOUNT) = ETHETA(I) 21 CONTINUE COUNT = N ELSE IF (NUML.GE.4) THEN LTHETA = MIDDLE + (LMIN1-MIDDLE) / 4.0D0 ADD = (LMIN1 - LMIN2)/(N-COUNT) DO 22 I = COUNT+1, N ETHETA(I) = LMIN2 + ADD*(I-COUNT) ACOUNT = ACOUNT + 1 ATHETA(ACOUNT) = ETHETA(I) 22 CONTINUE COUNT = N ELSE IF (NUMR.GE.4) THEN RTHETA = MIDDLE + (RMIN1-MIDDLE) / 4.0D0 ADD = (RMIN1 - RMIN2)/(N-COUNT) DO 23 I = COUNT+1, N ETHETA(I) = RMIN2 + ADD*(I-COUNT) ACOUNT = ACOUNT + 1 ATHETA(ACOUNT) = ETHETA(I) 23 CONTINUE COUNT = N ENDIF ELSE N = COUNT ENDIF * CHOOSE A SIGMA AND COMPUTE THE ATHETA'S SIGMA = EIGTRA(SIGMA,OSIGMA,PROB) SIGMA = SIGMA - 0.01*SIGMA IF (PROB.EQ.0) THEN DO 30 I = 1, ACOUNT ATHETA(I) = 1.0D0/(EIGTRA(ATHETA(I),OSIGMA,PROB) C -SIGMA) 30 CONTINUE ELSE DO 35 I = 1, ACOUNT * PRINT *,'ATHE = ',ATHETA(I),SIGMA,OSIGMA, * C EIGTRA(ATHETA(I),OSIGMA,PROB) ATHETA(I) = 1.0D0/(1.0D0-(SIGMA/ C EIGTRA(ATHETA(I),OSIGMA,PROB))) * PRINT *,'ATHETA = ',ATHETA(I),SIGMA,OSIGMA,EIGTRA(ATHETA(I), * C SIGMA,1) 35 CONTINUE ENDIF RETURN END SUBROUTINE UPDTC(EN,STEP,N,MAXN,ETHETA,C,ALPHA,BETA,BETA2,SHIFT, C IMAX,NUMS,EPS) INTEGER STEP, N, MAXN, EN, IMAX, NUMS DOUBLE PRECISION ETHETA(*),C(EN,*),ALPHA(*),BETA(*),BETA2(*), EPS LOGICAL SHIFT * INTERNAL VARS DOUBLE PRECISION TN, SUM INTEGER I, I2MAX * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION SINPRD EXTERNAL SINPRD, VECSAX, VECDSC, FLLVEC IF (.NOT.SHIFT) THEN IF (STEP.EQ.1) THEN TN = MAXN TN = SQRT(TN) CALL FLLVEC(N,C(1,1),1.0D0/TN) BETA(1) = 0.0D0 ENDIF ELSE IF (STEP.EQ.1) THEN TN = MAXN-2 TN = SQRT(0.5D0/TN) IMAX = 1 I2MAX = 1 DO 6 I = 1, N C(I,1) = TN IF (ABS(ETHETA(I)).GT.ABS(ETHETA(I2MAX))) THEN IF (ABS(ETHETA(I)).GT.ABS(ETHETA(IMAX))) THEN I2MAX=IMAX IMAX = I ELSE I2MAX = I ENDIF ENDIF 6 CONTINUE BETA(1) = 0.0D0 C(IMAX,1) = 0.5D0 C(I2MAX,1) = 0.5D0 ENDIF ENDIF ALPHA(STEP) = 0.0D0 DO 10 I = 1, N ALPHA(STEP) = ALPHA(STEP) + (C(I,STEP)*C(I,STEP))*ETHETA(I) 10 CONTINUE ALPHA(STEP) = ALPHA(STEP) + (MAXN-N)*(C(N,STEP)*C(N,STEP))* C ETHETA(N) IF (STEP.EQ.1) THEN CNORECUR DO 20 I = 1, N C(I,STEP+1) = (ETHETA(I)-ALPHA(STEP))*C(I,STEP) 20 CONTINUE ELSE CNORECUR DO 25 I = 1, N C(I,STEP+1) = (ETHETA(I)-ALPHA(STEP))*C(I,STEP)- C BETA(STEP)*C(I,STEP-1) 25 CONTINUE ENDIF * ORTHOGONALIZE C(STEP+1) VS PREVIOUS C'S DO 40 I = 1, STEP SUM = SINPRD(N,C(1,STEP+1),C(1,I)) SUM = SUM + (MAXN-N)*C(N,STEP+1)*C(N,I) CALL VECSAX(N,C(1,STEP+1),C(1,I),-SUM) 40 CONTINUE BETA2(STEP+1)=SINPRD(N,C(1,STEP+1),C(1,STEP+1)) BETA2(STEP+1) = BETA2(STEP+1) + (MAXN-N)*(C(N,STEP+1)* C C(N,STEP+1)) IF (BETA2(STEP+1).LT.0.0D0) BETA2(STEP+1) = ABS(BETA2(STEP+1)) BETA(STEP+1) = SQRT(BETA2(STEP+1)) IF (STEP.GT.1) THEN IF (BETA2(STEP+1)/BETA2(STEP).LT.EPS) THEN NUMS = STEP RETURN ENDIF ENDIF CALL VECDSC(N,C(1,STEP+1),C(1,STEP+1),BETA(STEP+1)) RETURN END C$FORTRAN PREP *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: PREP.MSC * * AUTHOR: MARK JONES * * PURPOSE: EXAMINES THE PARAMETERS PASSED INTO LANZ() * *********************************************************************** INTEGER FUNCTION PREP(IPARAM,RPARAM,INPARI,INPARR) * IPARAM IS A SET OF INTEGER PARAMETERS FOR LANCZOS INTEGER IPARAM(*) * RPARAM IS A SET OF DOUBLE PRECISION PARAMETERS FOR LANCZOS DOUBLE PRECISION RPARAM(*) * INPARI IS A SET OF INTEGER PARAMETERS FROM THE CALLING ROUTINE INTEGER INPARI(*) * INPARR IS A SET OF DOUBLE PRECISION PARAMETERS FOR LANCZOS DOUBLE PRECISION INPARR(*) * SOME LOCAL DECLARATIONS DOUBLE PRECISION DMACH EXTERNAL DMACH * RECONCILE AND CHECK THE PARAMETERS * THE ORDER OF THE MATRIX IPARAM(1) = INPARI(1) IF (IPARAM(1).LE.0) THEN PRINT *,'ERROR: IPAR(1): THE ORDER OF THE MATRIX, WAS ', C IPARAM(1) PREP = -1 RETURN ENDIF * THE MAXIMUM NUMBER OF EIGENVALUES THAT CAN BE STORED IPARAM(2) = INPARI(2) IF (IPARAM(2).LE.0) THEN PRINT *,'ERROR: IPAR(2): THE MAXIMUM NUMBER OF EIGENVALUES ', C 'THAT CAN BE STORED, WAS ',IPARAM(2) PREP = -1 RETURN ENDIF * THE NUMBER OF EIGENVALUES BEING SOUGHT IPARAM(3) = INPARI(3) IF (IPARAM(3).LE.0) THEN PRINT *,'ERROR: IPAR(3): THE NUMBER OF EIGENVALUES ', C 'TO FIND WAS, ',IPARAM(3) PREP = -1 RETURN ENDIF * THE MAXIMUM NUMBER OF LANCZOS STEPS TO TAKE IPARAM(4) = INPARI(4) IF (IPARAM(4).LE.0) THEN PRINT *,'ERROR: IPAR(4): THE MAXIMUM NUMBER OF LANCZOS ', C 'STEPS TO TAKE, WAS ',IPARAM(4) PREP = -1 RETURN ENDIF * DO WE PERFORM INERTIA CHECKING? IPARAM(5) = INPARI(9) IF ((IPARAM(5).LT.0).OR.(IPARAM(5).GT.1)) THEN PRINT *,'ERROR: IPAR(9): THE INERTIA CHECKING FLAG, ', C 'WAS ',IPARAM(5) PREP = -1 RETURN ENDIF * SET THE RETURN VALUE TO 0 * CORRESPONDS TO IPAR(5) IPARAM(6) = 0 * THE NUMBER OF EIGENVALUES ALREADY FOUND IPARAM(7) = INPARI(6) IF (IPARAM(7).LT.0) THEN PRINT *,'ERROR: IPAR(6): THE NUMBER OF EIGENVALUES ', C 'ALREADY FOUND, WAS ',IPARAM(7) PREP = -1 RETURN ENDIF * THE LEVEL OF DEBUGGING OUTPUT (WE DON'T CARE) IPARAM(8) = INPARI(7) * WHAT PROBLEM TO WORK ON? IPARAM(9) = INPARI(8) IF ((IPARAM(9).LT.0).OR.(IPARAM(9).GT.2)) THEN PRINT *,'ERROR: IPAR(8): THE PROBLEM TYPE, ', C 'WAS ',IPARAM(9) PREP = -1 RETURN ENDIF * THE LEVEL OF POST-PROCESSING TO DO IPARAM(10) = INPARI(10) IF (IPARAM(10).LT.0) THEN PRINT *,'ERROR: IPAR(10): THE TYPE OF PRINTED REPORT, ', C 'WAS ',IPARAM(10) PREP = -1 RETURN ENDIF * THE MAXIMUM NUMBER OF STEPS ON ONE SHIFT IPARAM(13) = INPARI(11) IF (IPARAM(13).LE.0) THEN PRINT *,'ERROR: IPAR(11): THE MAXIMUM NUMBER OF LANCZOS ', C 'STEPS TO TAKE ON A SINGLE SHIFT, WAS ',IPARAM(13) PREP = -1 RETURN ENDIF * DO WE WANT TO SEARCH IN A RANGE OR NOT? IPARAM(14) = INPARI(12) IF ((IPARAM(14).LT.0).OR.(IPARAM(14).GT.1)) THEN PRINT *,'ERROR: IPAR(12): INDICATING WHETHER TO SEARCH ONLY ', C 'IN A RANGE, WAS ',IPARAM(14) PREP = -1 RETURN ENDIF * THE STORAGE FORMAT FOR K (HAD BETTER BE 0) IPARAM(15) = INPARI(13) IF (IPARAM(15).NE.0) THEN PRINT *,'ERROR: IPAR(13): THE STORAGE FORMAT FOR K, ', C 'WAS ',IPARAM(15) PREP = -1 RETURN ENDIF * THE LEADING INDEX OF THE Y ARRAY IPARAM(16) = INPARI(19) IF (IPARAM(16).LE.0) THEN PRINT *,'ERROR: IPAR(19): THE LEADING INDEX OF Y, ', C 'WAS ',IPARAM(16) PREP = -1 RETURN ENDIF * THE STORAGE FORMAT FOR M (HAD BETTER BE 0) IPARAM(17) = INPARI(14) IF (IPARAM(17).NE.0) THEN PRINT *,'ERROR: IPAR(14): THE STORAGE FORMAT FOR M, ', C 'WAS ',IPARAM(17) PREP = -1 RETURN ENDIF * THE LEVEL OF LOOP UNROLLING IS ALWAYS 6 NOW IPARAM(18) = 6 * THE MAXIMUM NUMBER OF DELAYED PIVOTS IPARAM(20) = INPARI(20) IF (IPARAM(20).LT.0) THEN PRINT *,'ERROR: IPAR(20): THE STORAGE FOR DELAYED PIVOTS, ', C 'WAS ',IPARAM(20) PREP = -1 RETURN ENDIF * THE TYPE OF FACTORIZATION IPARAM(24) = INPARI(16) IF ((IPARAM(24).LT.0).OR.(IPARAM(24).GT.3)) THEN PRINT *,'ERROR: IPAR(16): THE TYPE OF FACTORIZATION, ', C 'WAS ',IPARAM(24) PREP = -1 RETURN ENDIF * DYNAMIC SHIFTING IPARAM(27) = INPARI(17) IF ((IPARAM(27).LT.0).OR.(IPARAM(27).GT.1)) THEN PRINT *,'ERROR: IPAR(17): THE DYNAMIC SHIFTING INDICATOR, ', C 'WAS ',IPARAM(27) PREP = -1 RETURN ENDIF * THE INITIAL GUESS IPARAM(29) = INPARI(18) IF ((IPARAM(29).LT.0).OR.(IPARAM(29).GT.1)) THEN PRINT *,'ERROR: IPAR(18): THE INITIAL GUESS INDICATOR, ', C 'WAS ',IPARAM(29) PREP = -1 RETURN ENDIF * THE SHIFT TO SEARCH AROUND RPARAM(1) = INPARR(1) * THE REQUIRED EIGENVALUE ACCURACY RPARAM(3) = INPARR(2) IF (RPARAM(3).LT.0.0D0) THEN PRINT *,'ERROR: RPAR(2): THE DESIRED RELATIVE ACCURACY, ', C 'WAS ',RPARAM(3) PREP = -1 RETURN ENDIF * THE LEFT SIDE OF THE BOUNDARY RPARAM(5) = INPARR(3) * THE RIGHT SIDE OF THE BOUNDARY RPARAM(6) = INPARR(4) * IF WE ARE SEARCHING IN A RANGE, CHECK TO MAKE SURE THE RANGE * IS SENSIBLE IF (IPARAM(14).EQ.1) THEN IF ((RPARAM(5)).GE.(RPARAM(6))) THEN PRINT *,'ERROR: RPAR(5) AND RPAR(6): THE RANGE BOUNDARIES ', C 'ARE INCORRECT, THEY ARE ',RPARAM(5),RPARAM(6) PREP = -1 RETURN ENDIF ENDIF * THE STORAGE FACTOR FOR B-K RPARAM(7) = INPARR(5) IF (RPARAM(7).LT.1.0D0) THEN PRINT *,'ERROR: RPAR(5): THE STORAGE FACTOR FOR ', C 'BUNCH-KAUFMAN BANDED FACTORIZATION, WAS ',RPARAM(7) PREP = -1 RETURN ENDIF * GET THE MACHINE PRECISION * WE DON'T READ THIS BUT INSTEAD COMPUTE IT USING SMACH FROM SBLAS RPARAM(2) = DMACH(1) RPARAM(4) = DMACH(3) * COMPARE THE NUMBER OF Y VECTORS TO STORE AGAINST THE NUMBER * TO FIND IF (IPARAM(3).GT.IPARAM(2)) THEN PRINT *,'WARNING: MAX EIGS SOUGHT TOO LARGE' IPARAM(3) = IPARAM(2) PRINT *,'FIXED: NUMBER RESET TO ',IPARAM(2) ENDIF * RESET TO SPARSE FACTORIZATION IF N IS LT 6 IF ((IPARAM(1).LE.6).AND.(IPARAM(24).LT.2)) THEN PRINT *,'NOTE: DUE TO THE STRUCTURE OF THE BANDED' PRINT *,'FACTORIZATION PROGRAMS, SMALL MATRICES ARE' PRINT *,'FACTORED USING THE SPARSE FACTORIZATION ROUTINES.' IPARAM(24) = 2 ENDIF * MAKE SURE THAT THE MAXIMUM NUMBER OF EIGENVALUES AND STEPS * IS LESS THAN OR EQUAL TO N IPARAM(2) = MIN(IPARAM(2),IPARAM(1)) IPARAM(3) = MIN(IPARAM(3),IPARAM(1)) IPARAM(13) = MIN(IPARAM(13),IPARAM(1)) * RETURN OKAY VALUE PREP = 0 RETURN END C$FORTRAN PURGE *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: PURGE.MSC * * AUTHOR: MARK JONES * * PURPOSE: DOES 1) EXTERNAL SELECTIVE ORTHOGONALIZATION * * 2) PARTIAL REORTHOGONALIZATION, AND * * 3) NORMALIZES Q(J+1) AND P(J+1) * *********************************************************************** SUBROUTINE PURGE(N,J,Q,P,P0,ALPHA,BETA,TBETA,BJ, C OEIGNM, C OTHETA,OLDBJ,LDI,Y,ONUMT,ETA0,ETA1,TAU0,TAU1, C RNORM,THETA,KAUX,KRP,KCP,MAUX,MRP,MCP,PTYPE,KSTORE,MSTORE, C DEBUG,SIGMA,DEPS,ORESET,WORKV1,WORKV2) * THE DIMENSION OF THE PROBLEM INTEGER N * THE CURRENT LANCZOS STEP INTEGER J * Q IS THE ARRAY OF LANCZOS VECTORS DOUBLE PRECISION Q(N,*) * P IS THE DIRECTION VECTOR AT STEP J DOUBLE PRECISION P(*) * P0 IS THE DIRECTION VECTOR AT STEP J-1 DOUBLE PRECISION P0(*) * ALPHA AND BETA ARE THE ARRAYS OF THE TRIDIAGONAL MATRIX, T DOUBLE PRECISION ALPHA(*), BETA(*) * SQUARE OF BETA(J+1) DOUBLE PRECISION TBETA * BJ IS AN ARRAY OF ERROR BOUNDS ON EIGENVALUES DOUBLE PRECISION BJ(*) * NUMBER OF OLD EIGENPAIRS GIVEN TO US INTEGER OEIGNM * OTHETA IS AN ARRAY OF OLD EIGENVALUES DOUBLE PRECISION OTHETA(*) * OLDBJ IS AN ARRAY OF ERROR BOUNDS ON OLD EIGENVALUES DOUBLE PRECISION OLDBJ(*) * THE LEADING DIMENSION OF Y INTEGER LDI * Y IS THE ARRAY OF EIGENVECTORS DOUBLE PRECISION Y(LDI,*) * ONUMT IS THE ARRAY INDICES FOR OLD EIGENVECTORS INTEGER ONUMT(*) * THIS IS A WORK VECTOR FOR LANCZOS DOUBLE PRECISION ETA0(*) * THIS IS A WORK VECTOR FOR LANCZOS DOUBLE PRECISION ETA1(*) * THE EXTERNAL TAU RECURRENCE DOUBLE PRECISION TAU0(*), TAU1(*) * THE NORM OF R AT THE PREVIOUS STEP DOUBLE PRECISION RNORM * THE EIGENVALUES DOUBLE PRECISION THETA(*) * AN AUXILLARY STIFFNESS MATRIX DOUBLE PRECISION KAUX(*) * A VECTOR ASSOCIATED WITH KAUX INTEGER KRP(*) * A VECTOR ASSOCIATED WITH KAUX INTEGER KCP(*) * AN AUXILLARY MASS MATRIX DOUBLE PRECISION MAUX(*) * A VECTOR ASSOCIATED WITH MAUX INTEGER MRP(*) * A VECTOR ASSOCIATED WITH MAUX INTEGER MCP(*) * THE PROBLEM TYPE INTEGER PTYPE * THE STORAGE TYPE OF M AND K INTEGER KSTORE, MSTORE * THE LEVEL OF DEBUGGING OUTPUT INTEGER DEBUG * THE SIGMA DOUBLE PRECISION SIGMA * THE SQRT OF MACHINE EPSILON DOUBLE PRECISION DEPS * THE BEGINNING LEVEL OF ORTHOGONALITY DOUBLE PRECISION ORESET * WORK ARRAYS DOUBLE PRECISION WORKV1(*), WORKV2(*) * THE FOLLOWING VARIABLES ARE INTERNAL VARIABLES * USED TO COMPUTE TAU RECURRENCE DOUBLE PRECISION OTAU2 * COUNT VARIABLES INTEGER I, K * LOGICAL VARIABLES FOR REORTHOGONALIZATION LOGICAL QORTHO, RORTHO * VARIABLES FOR VECTOR PARTITIONING * TEMPORARY VARIABLES USED IN REORTHOGONALIZATION DOUBLE PRECISION QTEMP, RTEMP DOUBLE PRECISION SQTEMP, SRTEMP, ET0MOD, ET1MOD, ETAMAX * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION SINPRD, SORTHO, REVEIG EXTERNAL SINPRD, SORTHO, REVEIG, APPINP, VECSAX, VECDSC * INITIALIZE THE VARIABLES TO COLLECT MODIFICATIONS TO * THE PRO RECURRENCE ET0MOD = 0.0D0 ET1MOD = 0.0D0 * ORTHOGONALIZE AGAINST THE OLD EIGENVECTORS QORTHO = .FALSE. RORTHO = .FALSE. DO 40 I = 1, OEIGNM IF (J.EQ.0) THEN TAU0(I) = 0.0D0 TAU1(I) = ORESET ELSE OTAU2 = ABS(((1.0D0/(OTHETA(I)-SIGMA))-ALPHA(J))* C TAU1(I)) OTAU2 = OTAU2 + BETA(J)*TAU0(I) OTAU2 = OTAU2 + ABS((1.0D0/(OTHETA(I)-SIGMA))* C OLDBJ(I)*OTHETA(I)*RNORM) OTAU2 = OTAU2/BETA(J+1) TAU0(I) = TAU1(I) TAU1(I) = OTAU2 ENDIF IF ((TAU1(I).GT.DEPS).OR.(J.EQ.0)) THEN IF ((J.GT.0).AND.(TAU0(I).GT.ORESET)) THEN * ORTHOGONALIZE Q(J) AGAINST Y(ONUMT(I)) QORTHO = .TRUE. QTEMP = SORTHO(N,Q(1,J),P0,Y(1,ONUMT(I)), C Y(1,ONUMT(I)),DEPS,QORTHO) ALPHA(J) = ALPHA(J) - QTEMP* C REVEIG(OTHETA(I),SIGMA,PTYPE)*QTEMP TAU0(I) = ORESET ET0MOD = ET0MOD + ABS(QTEMP)*DEPS ENDIF * ORTHOGONALIZE R AGAINST Y(ONUMT(I)) RORTHO = .TRUE. RTEMP = SORTHO(N,Q(1,J+1),P,Y(1,ONUMT(I)), C Y(1,ONUMT(I)),DEPS,RORTHO) TAU1(I) = ORESET ET1MOD = ET1MOD + ABS(RTEMP)*DEPS ENDIF 40 CONTINUE * UPDATE THE PRO RECURRENCE IF (J.EQ.0) THEN ETA0(1) = 0.0D0 ETA1(1) = 1.0D0 ETAMAX = 0.0D0 ELSE IF (DEBUG.GT.2) THEN PRINT *,'ETAMODS ',ET0MOD,ET1MOD ENDIF DO 10 I = 1, J-1 ETA0(I) = -ETA0(I)*BETA(J) C + ETA1(I)*(ALPHA(I)-ALPHA(J)) C + ETA1(I+1)*BETA(I+1) IF (I.GT.1) THEN ETA0(I) = ETA0(I) + ETA1(I-1)*BETA(I) ENDIF 10 CONTINUE DO 12 I = 1, J-1 QTEMP = ETA0(I)/BETA(J+1) ETA0(I) = ETA1(I) + ET0MOD ETA1(I) = QTEMP + ET1MOD IF (DEBUG.GT.2) THEN PRINT *,'ETA0, ETA1 ',ETA0(I),ETA1(I) ENDIF 12 CONTINUE ETAMAX = 0.0D0 DO 14 I = 1, J ETAMAX = MAX(ABS(ETA1(I)),ETAMAX) 14 CONTINUE IF (J.GT.0) THEN ETA0(J) = ETA1(J) + ET0MOD ETA1(J) = ORESET IF (J.GT.1) THEN ETA1(J-1) = ORESET + ET0MOD ENDIF ENDIF ETA1(J+1) = 1.0D0 ENDIF * REORTHGONALIZE Q AND R AGAINST THE PREVIOUS Q'S IF INDICATED IF (ETAMAX.GT.DEPS) THEN DO 20 I = 1, J-1 IF (J.GT.1) THEN QORTHO = .TRUE. QTEMP = SORTHO(N,Q(1,J),P0,Q(1,I),Q(1,I), C DEPS,QORTHO) IF (DEBUG.GT.2) THEN PRINT *,'QORTHO ',I,QTEMP,ETA0(I) ENDIF ETA0(I) = ORESET ENDIF RORTHO = .TRUE. RTEMP = SORTHO(N,Q(1,J+1),P,Q(1,I),Q(1,I), C DEPS,RORTHO) IF (DEBUG.GT.2) THEN PRINT *,'RORTHO ',I,RTEMP,ETA1(I) ENDIF ETA1(I) = ORESET 20 CONTINUE ENDIF * FIX UP THE CURRENT LANCZOS VECTORS IF (QORTHO.OR.RORTHO) THEN IF (J.GT.0) THEN IF (QORTHO) THEN CALL APPINP(N,P0,Q(1,J),PTYPE, C MSTORE,MAUX,MRP,MCP,KSTORE,KAUX,KRP,KCP) ENDIF SQTEMP = SINPRD(N,P0,Q(1,J+1)) CALL VECSAX(N,Q(1,J+1),Q(1,J),-SQTEMP) ENDIF CALL APPINP(N,P,Q(1,J+1),PTYPE, C MSTORE,MAUX,MRP,MCP,KSTORE,KAUX,KRP,KCP) TBETA = SINPRD(N,Q(1,J+1),P) BETA(J+1) = SQRT(TBETA) ENDIF * NORMALIZE R AND P CALL VECDSC(N,Q(1,J+1),Q(1,J+1),BETA(J+1)) CALL VECDSC(N,P,P,BETA(J+1)) RETURN END C$FORTRAN QMDMRG *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: QMDMRG.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: SEE BELOW * *********************************************************************** C----- SUBROUTINE QMDMRG C**************************************************************** C**************************************************************** C********** QMDMRG ..... QUOT MIN DEG MERGE *********** C**************************************************************** C**************************************************************** C C PURPOSE - THIS ROUTINE MERGES INDISTINGUISHABLE NODES IN C THE MINIMUM DEGREE ORDERING ALGORITHM. C IT ALSO COMPUTES THE NEW DEGREES OF THESE C NEW SUPERNODES. C C INPUT PARAMETERS - C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. C DEG0 - THE NUMBER OF NODES IN THE GIVEN SET. C (NHDSZE, NBRHD) - THE SET OF ELIMINATED SUPERNODES C ADJACENT TO SOME NODES IN THE SET. C C UPDATED PARAMETERS - C DEG - THE DEGREE VECTOR. C QSIZE - SIZE OF INDISTINGUISHABLE NODES. C QLINK - LINKED LIST FOR INDISTINGUISHABLE NODES. C MARKER - THE GIVEN SET IS GIVEN BY THOSE NODES WITH C MARKER VALUE SET TO 1. THOSE NODES WITH DEGREE C UPDATED WILL HAVE MARKER VALUE SET TO 2. C C WORKING PARAMETERS - C RCHSET - THE REACHABLE SET. C OVRLP - TEMP VECTOR TO STORE THE INTERSECTION OF TWO C REACHABLE SETS. C C**************************************************************** C SUBROUTINE QMDMRG ( XADJ, ADJNCY, DEG, QSIZE, QLINK, 1 MARKER, DEG0, NHDSZE, NBRHD, RCHSET, 1 OVRLP ) C C**************************************************************** C INTEGER ADJNCY(1), DEG(1), QSIZE(1), QLINK(1), 1 MARKER(1), RCHSET(1), NBRHD(1), OVRLP(1) INTEGER XADJ(1), DEG0, DEG1, HEAD, INHD, IOV, IRCH, 1 J, JSTRT, JSTOP, LINK, LNODE, MARK, MRGSZE, 1 NABOR, NHDSZE, NODE, NOVRLP, RCHSZE, ROOT C C**************************************************************** C C ------------------ C INITIALIZATION ... C ------------------ IF ( NHDSZE .LE. 0 ) RETURN DO 100 INHD = 1, NHDSZE ROOT = NBRHD(INHD) MARKER(ROOT) = 0 100 CONTINUE C ------------------------------------------------- C LOOP THROUGH EACH ELIMINATED SUPERNODE IN THE SET C (NHDSZE, NBRHD). C ------------------------------------------------- DO 1400 INHD = 1, NHDSZE ROOT = NBRHD(INHD) MARKER(ROOT) = - 1 RCHSZE = 0 NOVRLP = 0 DEG1 = 0 200 JSTRT = XADJ(ROOT) JSTOP = XADJ(ROOT+1) - 1 C ---------------------------------------------- C DETERMINE THE REACHABLE SET AND ITS INTERSECT- C ION WITH THE INPUT REACHABLE SET. C ---------------------------------------------- DO 600 J = JSTRT, JSTOP NABOR = ADJNCY(J) ROOT = - NABOR IF (NABOR) 200, 700, 300 C 300 MARK = MARKER(NABOR) IF ( MARK ) 600, 400, 500 400 RCHSZE = RCHSZE + 1 RCHSET(RCHSZE) = NABOR DEG1 = DEG1 + QSIZE(NABOR) MARKER(NABOR) = 1 GOTO 600 500 IF ( MARK .GT. 1 ) GOTO 600 NOVRLP = NOVRLP + 1 OVRLP(NOVRLP) = NABOR MARKER(NABOR) = 2 600 CONTINUE C -------------------------------------------- C FROM THE OVERLAPPED SET, DETERMINE THE NODES C THAT CAN BE MERGED TOGETHER. C -------------------------------------------- 700 HEAD = 0 MRGSZE = 0 DO 1100 IOV = 1, NOVRLP NODE = OVRLP(IOV) JSTRT = XADJ(NODE) JSTOP = XADJ(NODE+1) - 1 DO 800 J = JSTRT, JSTOP NABOR = ADJNCY(J) IF ( MARKER(NABOR) .NE. 0 ) GOTO 800 MARKER(NODE) = 1 GOTO 1100 800 CONTINUE C ----------------------------------------- C NODE BELONGS TO THE NEW MERGED SUPERNODE. C UPDATE THE VECTORS QLINK AND QSIZE. C ----------------------------------------- MRGSZE = MRGSZE + QSIZE(NODE) MARKER(NODE) = - 1 LNODE = NODE 900 LINK = QLINK(LNODE) IF ( LINK .LE. 0 ) GOTO 1000 LNODE = LINK GOTO 900 1000 QLINK(LNODE) = HEAD HEAD = NODE 1100 CONTINUE IF ( HEAD .LE. 0 ) GOTO 1200 QSIZE(HEAD) = MRGSZE DEG(HEAD) = DEG0 + DEG1 - 1 MARKER(HEAD) = 2 C -------------------- C RESET MARKER VALUES. C -------------------- 1200 ROOT = NBRHD(INHD) MARKER(ROOT) = 0 IF ( RCHSZE .LE. 0 ) GOTO 1400 DO 1300 IRCH = 1, RCHSZE NODE = RCHSET(IRCH) MARKER(NODE) = 0 1300 CONTINUE 1400 CONTINUE RETURN END C$FORTRAN QMDQT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: QMDQT.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: SEE BELOW * *********************************************************************** C----- SUBROUTINE QMDQT C************************************************************* C************************************************************* C******* QMDQT ..... QUOT MIN DEG QUOT TRANSFORM ******* C************************************************************* C************************************************************* C C PURPOSE - THIS SUBROUTINE PERFORMS THE QUOTIENT GRAPH C TRANSFORMATION AFTER A NODE HAS BEEN ELIMINATED. C C INPUT PARAMETERS - C ROOT - THE NODE JUST ELIMINATED. IT BECOMES THE C REPRESENTATIVE OF THE NEW SUPERNODE. C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. C (RCHSZE, RCHSET) - THE REACHABLE SET OF ROOT IN THE C OLD QUOTIENT GRAPH. C NBRHD - THE NEIGHBORHOOD SET WHICH WILL BE MERGED C WITH ROOT TO FORM THE NEW SUPERNODE. C MARKER - THE MARKER VECTOR. C C UPDATED PARAMETER - C ADJNCY - BECOMES THE ADJNCY OF THE QUOTIENT GRAPH. C C************************************************************* C SUBROUTINE QMDQT ( ROOT, XADJ, ADJNCY, MARKER, 1 RCHSZE, RCHSET, NBRHD ) C C************************************************************* C INTEGER ADJNCY(1), MARKER(1), RCHSET(1), NBRHD(1) INTEGER XADJ(1), INHD, IRCH, J, JSTRT, JSTOP, LINK, 1 NABOR, NODE, RCHSZE, ROOT C C************************************************************* C IRCH = 0 INHD = 0 NODE = ROOT 100 JSTRT = XADJ(NODE) JSTOP = XADJ(NODE+1) - 2 IF ( JSTOP .LT. JSTRT ) GO TO 300 C ------------------------------------------------ C PLACE REACH NODES INTO THE ADJACENT LIST OF NODE C ------------------------------------------------ DO 200 J = JSTRT, JSTOP IRCH = IRCH + 1 ADJNCY(J) = RCHSET(IRCH) IF ( IRCH .GE. RCHSZE ) GOTO 400 200 CONTINUE C ---------------------------------------------- C LINK TO OTHER SPACE PROVIDED BY THE NBRHD SET. C ---------------------------------------------- 300 LINK = ADJNCY(JSTOP+1) NODE = - LINK IF ( LINK .LT. 0 ) GOTO 100 INHD = INHD + 1 NODE = NBRHD(INHD) ADJNCY(JSTOP+1) = - NODE GO TO 100 C ------------------------------------------------------- C ALL REACHABLE NODES HAVE BEEN SAVED. END THE ADJ LIST. C ADD ROOT TO THE NBR LIST OF EACH NODE IN THE REACH SET. C ------------------------------------------------------- 400 ADJNCY(J+1) = 0 DO 600 IRCH = 1, RCHSZE NODE = RCHSET(IRCH) IF ( MARKER(NODE) .LT. 0 ) GOTO 600 JSTRT = XADJ(NODE) JSTOP = XADJ(NODE+1) - 1 DO 500 J = JSTRT, JSTOP NABOR = ADJNCY(J) IF ( MARKER(NABOR) .GE. 0 ) GO TO 500 ADJNCY(J) = ROOT GOTO 600 500 CONTINUE 600 CONTINUE RETURN END C$FORTRAN QMDRCH *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: QMDRCH.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: SEE BELOW * *********************************************************************** C----- SUBROUTINE QMDRCH C*************************************************************** C*************************************************************** C********* QMDRCH ..... QUOT MIN DEG REACH SET ********** C*************************************************************** C*************************************************************** C C PURPOSE - THIS SUBROUTINE DETERMINES THE REACHABLE SET OF C A NODE THROUGH A GIVEN SUBSET. THE ADJACENCY STRUCTURE C IS ASSUMED TO BE STORED IN A QUOTIENT GRAPH FORMAT. C C INPUT PARAMETERS - C ROOT - THE GIVEN NODE NOT IN THE SUBSET. C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE PAIR. C DEG - THE DEGREE VECTOR. DEG(I) LT 0 MEANS THE NODE C BELONGS TO THE GIVEN SUBSET. C C OUTPUT PARAMETERS - C (RCHSZE, RCHSET) - THE REACHABLE SET. C (NHDSZE, NBRHD) - THE NEIGHBORHOOD SET. C C UPDATED PARAMETERS - C MARKER - THE MARKER VECTOR FOR REACH AND NBRHD SETS. C GT 0 MEANS THE NODE IS IN REACH SET. C LT 0 MEANS THE NODE HAS BEEN MERGED WITH C OTHERS IN THE QUOTIENT OR IT IS IN NBRHD SET. C C*************************************************************** C SUBROUTINE QMDRCH ( ROOT, XADJ, ADJNCY, DEG, MARKER, 1 RCHSZE, RCHSET, NHDSZE, NBRHD ) C C*************************************************************** C INTEGER ADJNCY(1), DEG(1), MARKER(1), 1 RCHSET(1), NBRHD(1) INTEGER XADJ(1), I, ISTRT, ISTOP, J, JSTRT, JSTOP, 1 NABOR, NHDSZE, NODE, RCHSZE, ROOT C C*************************************************************** C C ----------------------------------------- C LOOP THROUGH THE NEIGHBORS OF ROOT IN THE C QUOTIENT GRAPH. C ----------------------------------------- NHDSZE = 0 RCHSZE = 0 ISTRT = XADJ(ROOT) ISTOP = XADJ(ROOT+1) - 1 IF ( ISTOP .LT. ISTRT ) RETURN DO 600 I = ISTRT, ISTOP NABOR = ADJNCY(I) IF ( NABOR .EQ. 0 ) RETURN IF ( MARKER(NABOR) .NE. 0 ) GO TO 600 IF ( DEG(NABOR) .LT. 0 ) GO TO 200 C ------------------------------------- C INCLUDE NABOR INTO THE REACHABLE SET. C ------------------------------------- RCHSZE = RCHSZE + 1 RCHSET(RCHSZE) = NABOR MARKER(NABOR) = 1 GO TO 600 C ------------------------------------- C NABOR HAS BEEN ELIMINATED. FIND NODES C REACHABLE FROM IT. C ------------------------------------- 200 MARKER(NABOR) = -1 NHDSZE = NHDSZE + 1 NBRHD(NHDSZE) = NABOR 300 JSTRT = XADJ(NABOR) JSTOP = XADJ(NABOR+1) - 1 DO 500 J = JSTRT, JSTOP NODE = ADJNCY(J) NABOR = - NODE IF (NODE) 300, 600, 400 400 IF ( MARKER(NODE) .NE. 0 ) GO TO 500 RCHSZE = RCHSZE + 1 RCHSET(RCHSZE) = NODE MARKER(NODE) = 1 500 CONTINUE 600 CONTINUE RETURN END C$FORTRAN QMDUPD *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: QMDUPD.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: SEE BELOW * *********************************************************************** C----- SUBROUTINE QMDUPD C**************************************************************** C**************************************************************** C********** QMDUPD ..... QUOT MIN DEG UPDATE *********** C**************************************************************** C**************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS DEGREE UPDATE FOR A SET C OF NODES IN THE MINIMUM DEGREE ALGORITHM. C C INPUT PARAMETERS - C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. C (NLIST, LIST) - THE LIST OF NODES WHOSE DEGREE HAS TO C BE UPDATED. C C UPDATED PARAMETERS - C DEG - THE DEGREE VECTOR. C QSIZE - SIZE OF INDISTINGUISHABLE SUPERNODES. C QLINK - LINKED LIST FOR INDISTINGUISHABLE NODES. C MARKER - USED TO MARK THOSE NODES IN REACH/NBRHD SETS. C C WORKING PARAMETERS - C RCHSET - THE REACHABLE SET. C NBRHD - THE NEIGHBORHOOD SET. C C PROGRAM SUBROUTINES - C QMDMRG. C C**************************************************************** C SUBROUTINE QMDUPD ( XADJ, ADJNCY, NLIST, LIST, DEG, 1 QSIZE, QLINK, MARKER, RCHSET, NBRHD ) C C**************************************************************** C INTEGER ADJNCY(1), LIST(1), DEG(1), MARKER(1), 1 RCHSET(1), NBRHD(1), QSIZE(1), QLINK(1) INTEGER XADJ(1), DEG0, DEG1, IL, INHD, INODE, IRCH, 1 J, JSTRT, JSTOP, MARK, NABOR, NHDSZE, NLIST, 1 NODE, RCHSZE, ROOT C C**************************************************************** C C ------------------------------------------------ C FIND ALL ELIMINATED SUPERNODES THAT ARE ADJACENT C TO SOME NODES IN THE GIVEN LIST. PUT THEM INTO C (NHDSZE, NBRHD). DEG0 CONTAINS THE NUMBER OF C NODES IN THE LIST. C ------------------------------------------------ IF ( NLIST .LE. 0 ) RETURN DEG0 = 0 NHDSZE = 0 DO 200 IL = 1, NLIST NODE = LIST(IL) DEG0 = DEG0 + QSIZE(NODE) JSTRT = XADJ(NODE) JSTOP = XADJ(NODE+1) - 1 DO 100 J = JSTRT, JSTOP NABOR = ADJNCY(J) IF ( MARKER(NABOR) .NE. 0 .OR. 1 DEG(NABOR) .GE. 0 ) GO TO 100 MARKER(NABOR) = - 1 NHDSZE = NHDSZE + 1 NBRHD(NHDSZE) = NABOR 100 CONTINUE 200 CONTINUE C -------------------------------------------- C MERGE INDISTINGUISHABLE NODES IN THE LIST BY C CALLING THE SUBROUTINE QMDMRG. C -------------------------------------------- IF ( NHDSZE .GT. 0 ) 1 CALL QMDMRG ( XADJ, ADJNCY, DEG, QSIZE, QLINK, 1 MARKER, DEG0, NHDSZE, NBRHD, RCHSET, 1 NBRHD(NHDSZE+1) ) C ---------------------------------------------------- C FIND THE NEW DEGREES OF THE NODES THAT HAVE NOT BEEN C MERGED. C ---------------------------------------------------- DO 600 IL = 1, NLIST NODE = LIST(IL) MARK = MARKER(NODE) IF ( MARK .GT. 1 .OR. MARK .LT. 0 ) GO TO 600 MARKER(NODE) = 2 CALL QMDRCH ( NODE, XADJ, ADJNCY, DEG, MARKER, 1 RCHSZE, RCHSET, NHDSZE, NBRHD ) DEG1 = DEG0 IF ( RCHSZE .LE. 0 ) GO TO 400 DO 300 IRCH = 1, RCHSZE INODE = RCHSET(IRCH) DEG1 = DEG1 + QSIZE(INODE) MARKER(INODE) = 0 300 CONTINUE 400 DEG(NODE) = DEG1 - 1 IF ( NHDSZE .LE. 0 ) GO TO 600 DO 500 INHD = 1, NHDSZE INODE = NBRHD(INHD) MARKER(INODE) = 0 500 CONTINUE 600 CONTINUE RETURN END C$FORTRAN READIT *********************************************************************** * LANZ SOFTWARE PACKAGE (PART OF TEST PROGRAM)* * FILENAME: READIT.MSC * * AUTHOR: MARK JONES * * PURPOSE: READ IN MATRICES FROM FILES * *********************************************************************** SUBROUTINE RDGSP(LIBNUM,MSDN,A,ARP,ACP,TMEM,LOCA,LOCARP,LOCACP, C RTOJ,LOCRTO,ORDER,N,JDOF,DOF,OUTFRM,OUTFIL,INFRM,INFIL, C SIZE1,SIZE2,SIZE3,ADDR1,ADDR2,ADDR3,ADDR4) * THE LIBRARY NUMBER (TO BE IGNORED IF NOT IN TESTBED) INTEGER LIBNUM * THE DATASET SEQUENCE NUMBER (TO BE IGNORED IF NOT IN TESTBED) INTEGER MSDN * THE MATRIX TO READ IN DOUBLE PRECISION A(*) * THE ROW POINTERS OF THAT MATRIX INTEGER ARP(*) * THE COLUMN INDICES OF THAT MATRIX INTEGER ACP(*) * THE TOTAL MEMORY ALLOCATED INTEGER TMEM * OFFSETS FROM MEMORY ALLOCATION INTEGER LOCA, LOCARP, LOCACP * THE ROW TO JOINT VECTOR (IGNORED IF NOT IN TESTBED) INTEGER RTOJ(*) * OFFSET FOR RTOJ ALLOCATION INTEGER LOCRTO * HAVE WE ALREADY GOT THE RTOJ DATA? LOGICAL ORDER * THE ORDER OF THE SYSTEM INTEGER N * THE JOINT DEGREES OF FREEDOM (IGNORED IF NOT IN TESTBED) INTEGER JDOF * THE DEGREES OF FREEDOM (IGNORED IF NOT IN TESTBED) INTEGER DOF * THE FORMAT TO WRITE OUT (0=NONE,1=ASCII,2=BINARY) INTEGER OUTFRM * THE FILE NUMBER TO WRITE TO (FORT.?) INTEGER OUTFIL * THE FORMAT TO READ OUT (0=TESTBED,1=ASCII,2=BINARY) INTEGER INFRM * THE FILE NUMBER TO READ FROM (FORT.?) INTEGER INFIL * THE SIZE OF THE ALLOCATED VECTORS INTEGER SIZE1, SIZE2, SIZE3 * THE ADDRESS OF THE ALLOCATED VECTORS INTEGER ADDR1, ADDR2, ADDR3, ADDR4 * INTERNAL VARIABLES * THE NUMBER OF OFF-DIAGONALS INTEGER ICOEFF * A LOOP COUNTER INTEGER I * IF READING IN IN TESTBED FORMAT IF (INFRM.EQ.0) THEN * IF READING IN IN ASCII FORMAT ELSE IF (INFRM.EQ.1) THEN READ(INFIL,*) N,ICOEFF * IF READING IN IN UNFORMATTED MODE ELSE IF (INFRM.EQ.2) THEN READ(INFIL) N,ICOEFF ENDIF * WRITE TO A FILE IF WE ARE SUPPOSSED TO * ASCII MODE IF (OUTFRM.EQ.1) THEN WRITE(OUTFIL,*) N,ICOEFF * UNFORMATTED MODE ELSE IF (OUTFRM.EQ.2) THEN WRITE(OUTFIL) N,ICOEFF ENDIF * ALLOCATE THE NECESSARY MEMORY (FOR 2 COPIES OF THE MATRIX) * ALLOCATE SPACE FOR THE NONZEROES SIZE1 = 2*(N+ICOEFF) CALL FALLOC(SIZE1,0,A,TMEM,LOCA,ADDR1) * ALLOCATE SPACE FOR THE ROW POINTERS SIZE2 = 2*(N+1) CALL FALLOC(SIZE2,1,ARP,TMEM,LOCARP,ADDR2) * ALLOCATE SPACE FOR THE COLUMN NUMBERS SIZE3 = 2*(ICOEFF+1)+N CALL FALLOC(SIZE3,1,ACP,TMEM,LOCACP,ADDR3) * NOW READ IN THE DIAGONAL OF K * IF IN TESTBED FORMAT IF (INFRM.EQ.0) THEN * IF IN ASCII FORMAT ELSE IF (INFRM.EQ.1) THEN DO 21 I = 1, N READ(INFIL,*) A(LOCA-1+I) 21 CONTINUE * IF IN UNFORMATTED MODE ELSE IF (INFRM.EQ.2) THEN READ(INFIL) (A(LOCA-1+I),I=1,N) ENDIF * WRITE TO A FILE IF WE ARE SUPPOSSED TO * ASCII FORMAT IF (OUTFRM.EQ.1) THEN DO 22 I = 1, N WRITE(OUTFIL,*) A(LOCA-1+I) 22 CONTINUE * UNFORMATTED WRITE ELSE IF (OUTFRM.EQ.2) THEN WRITE(OUTFIL) (A(LOCA-1+I),I=1,N) ENDIF * READ IN THE ROW POINTERS * IN TESTBED FORMAT IF (INFRM.EQ.0) THEN * READ IN ASCII FORMAT ELSE IF (INFRM.EQ.1) THEN DO 31 I = 1, N+1 READ(INFIL,*) ARP(LOCARP-1+I) 31 CONTINUE * READ IN UNFORMATTED MODE ELSE IF (INFRM.EQ.2) THEN READ(INFIL) (ARP(LOCARP-1+I),I=1,N+1) ENDIF * WRITE TO A FILE IF WE ARE SUPPOSSED TO * ASCII FORMAT IF (OUTFRM.EQ.1) THEN DO 32 I = 1, N+1 WRITE(OUTFIL,*) ARP(LOCARP-1+I) 32 CONTINUE * UNFORMATTED MODE ELSE IF (OUTFRM.EQ.2) THEN WRITE(OUTFIL) (ARP(LOCARP-1+I),I=1,N+1) ENDIF * READ IN THE COLUMN INDICES * TESTBED FORMAT IF (INFRM.EQ.0) THEN * ASCII FORMAT ELSE IF (INFRM.EQ.1) THEN DO 56 I = 1, ICOEFF READ(INFIL,*) ACP(LOCACP+I-1) 56 CONTINUE * UNFORMATTED MODE ELSE IF (INFRM.EQ.2) THEN READ(INFIL) (ACP(LOCACP-1+I),I=1,ICOEFF) ENDIF * WRITE OUT COLUMN NUMBERS * WRITE IN ASCII FORMAT IF (OUTFRM.EQ.1) THEN DO 55 I = 1, ICOEFF WRITE(OUTFIL,*) ACP(LOCACP+I-1) 55 CONTINUE * WRITE IN UNFORMATTED MODE ELSE IF (OUTFRM.EQ.2) THEN WRITE(OUTFIL) (ACP(LOCACP-1+I),I=1,ICOEFF) ENDIF * READ IN THE OFF-DIAGONALS OF A * TESTBED FORMAT IF (INFRM.EQ.0) THEN * ASCII FORMAT ELSE IF (INFRM.EQ.1) THEN DO 41 I = 1, ICOEFF READ(INFIL,*) A(LOCA-1+I+N) 41 CONTINUE * UNFORMATTED MODE ELSE IF (INFRM.EQ.2) THEN READ(INFIL) (A(LOCA-1+I+N),I=1,ICOEFF) ENDIF * WRITE OUT THE OFF-DIAGONALS * ASCII FORMAT IF (OUTFRM.EQ.1) THEN DO 40 I = 1, ICOEFF WRITE(OUTFIL,*) A(LOCA-1+I+N) 40 CONTINUE * UNFORMATTED MODE ELSE IF (OUTFRM.EQ.2) THEN WRITE(OUTFIL) (A(LOCA-1+I+N),I=1,ICOEFF) ENDIF RETURN END * NOT USED UNLESS IN FULL MATRIX MODE C$FORTRAN SPFACT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: SPFACT.MSC * * AUTHOR: MARK JONES * * PURPOSE: SPARSE INDEFINITE FACTORIZATION OR POSITIVE DEFINITE * * FACTORIZATION, DEPENDING ON IF SPBK IS SPECIFIED AT * * COMPILATION. * *********************************************************************** * SPARSE INDEFINITE FACTORIZATION WITH COMPRESSED STORAGE SUBROUTINE IFACT(N,DIAG,XLNZ,LNZ,XNZSUB,NZSUB,TPIV,T2PIV, C PERM,QSIZE,INERT,START,BORDER,SUBDAG, C DELAY,DELSPC,DORDER,DEBUG,MAXDLY,WORKV) * THE SIZE OF FA INTEGER N * THE DIAGONAL OF FA DOUBLE PRECISION DIAG(*) * THE OFF-DIAGONALS OF FA DOUBLE PRECISION LNZ(*) * THE ROW POINTERS INTO FA INTEGER XLNZ(*) * THE COMPRESSED SUBSCRIPT ARRAYS INTEGER NZSUB(*), XNZSUB(*) * TEMPORARILY HOLDS THE PIVOT COLUMN * T2PIV ALSO HOLDS THE RATIO OF A(I)/A(I,I) IN THE PIVOT * COMBINING PHASE DOUBLE PRECISION TPIV(*), T2PIV(*) * THE PERMUTATION VECTOR INTEGER PERM(*) * THE SUPERNODE SIZE VECTOR INTEGER QSIZE(*) * THE INERTIA OF A INTEGER INERT * HOLDS STARTING PLACES INSIDE VECTORS INTEGER START(*) * THE ORDERING INDUCED BY B-K INTEGER BORDER(*) * THE SUBDIAGONAL DOUBLE PRECISION SUBDAG(*) * A LIST OF ROWS DELAYED TO THE END INTEGER DELAY(*) * SPACE FOR THE DELAYED ROWS DOUBLE PRECISION DELSPC(N,*) * PERMUTATION VECTOR IN THE DELAYED ROWS INTEGER DORDER(*) * THE LEVEL OF DEBUGGING DESIRED INTEGER DEBUG * THE MAXIMUM NUMBER OF DELAYED PIVOTS THAT CAN BE STORED INTEGER MAXDLY * A DOUBLE PRECISION WORK VECTOR DOUBLE PRECISION WORKV(*) * INTERNALLY DECLARED VARIABLES * NUMBER OF ROWS DELAYED INTEGER NUMDLY * TEMPORARY VALUES INTEGER I, J, K, M, CNT, FIRST, LAST, CNT2 INTEGER COL, RIND, R2IND, IROW, ISTART INTEGER ROWI, ROWI1, ROWIR INTEGER NZSTRT, NZEND, TQSIZE * ARE WE FINISHED TRYING TO COMBINE PIVOT COLUMNS LOGICAL DONE * USE TO COMPUTE THE LEGAL GROWTH RATE DOUBLE PRECISION CRTSUM, CRIT, GRATE, CVAL * USE IN PERFORMING UPDATE OF REMAINING NON-ZEROES INTEGER M1, M2, M3, M4, M5, M6 DOUBLE PRECISION T1, TD, T2, T3, T4, T5, T6 * TEMPORARY VALUE INTEGER LENGTH, TLAST * A TEMPORARY HOLDING PLACE FOR THE PIVOT BLOCK DOUBLE PRECISION DENSE(6,6) * THE NUMBER OF SUPER NODES INTEGER ISNODE * THE MINIMUM MU THAT IS NEEDED TO GET A 1X1 PIVOT INTEGER MUIND * INDICATES THAT A SWITCH OF ROWS(AND COLUMNS) IS NEEDED LOGICAL SWITCH * USE IN COMPUTING THE 2X2 PIVOTS DOUBLE PRECISION A,B,C,MU,DET, MUMIN * A TEMPORARY VALUE FOR K INTEGER TRANK * THE MAXIMUM VALUE IN A PIVOT COLUMN DOUBLE PRECISION LAMBDA * HAS A WARNING ALREADY BEEN ISSUED IF THE SPACE FOR DELAYED * PIVOTS HAS BEEN EXCEEDED LOGICAL WARNED * INTEGER FUNCTIONS INTEGER IGETMX EXTERNAL FLLVEC, IGETMX WARNED = .FALSE. IF (DEBUG.GT.0) THEN ISNODE = 0 DO 1 I = 1, N IF (QSIZE(I).NE.0) ISNODE = ISNODE + 1 1 CONTINUE PRINT *,'THE NUMBER OF SUPERNODES IS ',ISNODE,N/FLOAT(ISNODE) ENDIF CVAL = 0.525D0 CRIT = 1.0D0 + (1.0D0/CVAL) CRIT2 = CRIT*CRIT * INITIALIZE THE ORDER VARIABLES AND THE SUBDIAGONAL NUMDLY = 0 I = 1 10 CONTINUE LAST = I+QSIZE(PERM(I))-1 DO 15 J = I, LAST BORDER(J) = I SUBDAG(J) = 0.0D0 15 CONTINUE I = LAST + 1 IF (I.LE.N) GOTO 10 BORDER(N+1) = 0 INERT = 0 I = 1 100 CONTINUE LAST = I-1+QSIZE(PERM(I)) LAST = MIN(LAST,I+5) TQSIZE = LAST - I + 1 * LOAD THE TRIANGLE INTO A DENSE MATRIX AND FACTOR IT DO 110 J = 1, TQSIZE DENSE(J,J) = DIAG(I+J-1) ISTART = XLNZ(I+J-1) DO 120 K = J+1, TQSIZE DENSE(K,J) = LNZ(ISTART) ISTART = ISTART + 1 120 CONTINUE DO 130 K = 1, J-1 T1 = DENSE(J,K)*DENSE(K,K) DO 140 M = J, TQSIZE DENSE(M,J) = DENSE(M,J) - DENSE(M,K)*T1 140 CONTINUE 130 CONTINUE CNORECUR DO 145 K = J+1, TQSIZE DENSE(K,J) = DENSE(K,J)/DENSE(J,J) 145 CONTINUE 110 CONTINUE * DETERMINE THE NUMBER OF PIVOT COLUMNS TO USE * FIRST, SEARCH THE PIVOT COLUMNS FOR THEIR MAXIMUM ELEMENT IF (XLNZ(I+1)-XLNZ(I).GT.0) THEN MUIND = IGETMX(XLNZ(I),XLNZ(I+1)-1,1,LNZ,T2PIV(I)) MUIND = NZSUB(XNZSUB(I)+MUIND-XLNZ(I)) ELSE T2PIV(I) = 0.0D0 MUIND = NZSUB(XNZSUB(I)) ENDIF * SEARCH IN DELAYED ROWS DO 148 J = 1, NUMDLY T1 = ABS(DELSPC(I-NUMDLY,J)) IF (T1.GT.T2PIV(I)) THEN T2PIV(I) = T1 MUIND = -J ENDIF 148 CONTINUE DO 150 J = I+1, LAST T2PIV(J) = 0.0D0 DO 160 K = XLNZ(J), XLNZ(J+1)-1 T2PIV(J) = MAX(T2PIV(J),ABS(LNZ(K))) 160 CONTINUE * SEARCH IN DELAYED ROWS DO 161 K = 1, NUMDLY T2PIV(J) = MAX(T2PIV(J),ABS(DELSPC(J-NUMDLY,K))) 161 CONTINUE 150 CONTINUE * NOW FIND HOW MANY CAN BE COMBINED J = I DONE = .FALSE. TLAST = I-1 CRTSUM = CRIT GRATE = 1.0D0 200 CONTINUE TPIV(J) = T2PIV(J) DO 205 K = I, J-1 TPIV(J) = TPIV(J) + TPIV(K)*ABS(DENSE(J-I+1,K-I+1)) 205 CONTINUE GRATE = GRATE*(1.0D0+TPIV(J)/ABS(DENSE(J-I+1,J-I+1))) IF (GRATE.LE.CRTSUM) THEN TLAST = J ELSE IF (GRATE.GT.CRTSUM*CRIT2) THEN DONE = .TRUE. ENDIF J = J + 1 CRTSUM = CRTSUM * CRIT IF ((J.LE.LAST).AND.(.NOT.DONE)) GOTO 200 IF (TLAST.NE.I+QSIZE(PERM(I))-1) THEN IF (TLAST.LT.I) THEN MUMIN = CVAL*(T2PIV(I)**2)/ABS(DENSE(1,1)) IF (MUIND.GT.0) THEN TLAST = LAST LAST = I * FIRST SEARCH ROW MUIND, BECAUSE IT IS EASIEST IF (ABS(DIAG(MUIND)).GE.MUMIN) THEN GOTO 930 ENDIF DO 940 J = XLNZ(MUIND), XLNZ(MUIND+1)-1 IF (ABS(LNZ(J)).GE.MUMIN) THEN GOTO 930 ENDIF 940 CONTINUE * SEARCH THE PART OF THE COLUMN IN THE DELAYED ROWS DO 950 J = 1, NUMDLY IF (ABS(DELSPC(MUIND-NUMDLY,J)).GE.MUMIN) THEN GOTO 930 ENDIF 950 CONTINUE DO 900 J = I+1, MUIND-1 CNT = XNZSUB(J) DO 910 K = XLNZ(J), XLNZ(J+1)-1 IF (NZSUB(CNT).GT.MUIND) GOTO 920 IF (NZSUB(CNT).EQ.MUIND) THEN IF (ABS(LNZ(K)).GE.MUMIN) THEN GOTO 930 ENDIF ENDIF CNT = CNT + 1 910 CONTINUE 920 CONTINUE 900 CONTINUE ELSE * SEARCH ACROSS IN THE DELAYED ROWS DO 960 J = I-NUMDLY, N-(MUIND+NUMDLY) IF (ABS(DELSPC(J,-MUIND)).GE.MUMIN) THEN GOTO 930 ENDIF 960 CONTINUE DO 970 J = -MUIND+1,NUMDLY IF (ABS(DELSPC(N-(NUMDLY+MUIND),J)).GE.MUMIN) THEN GOTO 930 ENDIF 970 CONTINUE ENDIF IF (DEBUG.GT.0) THEN PRINT *,'NEED A 2X2 PIVOT' ENDIF SWITCH = .FALSE. IF ((MUIND.LE.TLAST).AND.(MUIND.GT.0)) THEN IF (DEBUG.GT.0) THEN PRINT *,'WE CAN USE MUIND FOR THE 2X2' ENDIF SWITCH = .TRUE. ELSE IF (DEBUG.GT.0) THEN PRINT *,'TRY TO SEE IF ONE IN GROUP WILL DO' ENDIF A = ABS(DIAG(I)) DO 2500 J = I+1, TLAST MU = MAX(T2PIV(J),ABS(DIAG(J))) CNORECUR DO 2600 K = I+1, J-1 MU = MAX(MU,ABS(LNZ(XLNZ(K)+J-(K+1)))) 2600 CONTINUE B = ABS(LNZ(XLNZ(I)+J-(I+1))) C = ABS(DIAG(J)) IF (B.NE.0) THEN DET = ABS(((A*C/B)-B)*B) GRATE = 1.0D0 + (T2PIV(I)*C+2*MU*B+ C MU*A)/DET GRATE = MIN((1.0D0 + (T2PIV(I)*C+2*MU*B+ C (MU**2)*CRIT)/DET),GRATE) IF (GRATE.LE.CRIT2) THEN SWITCH = .TRUE. MUIND = J IF (DEBUG.GT.0) THEN PRINT *,'FOUND AN OK PIVOT IN GROUP ',I ENDIF GOTO 2700 ENDIF ENDIF 2500 CONTINUE 2700 CONTINUE ENDIF IF (SWITCH) THEN IF (DEBUG.GT.0) THEN PRINT *,'DOING THE 2X2' ENDIF IF (MUIND.NE.I+1) THEN IF (DEBUG.GT.0) THEN PRINT *,'PERMUTING ',I+1,' AND ',MUIND ENDIF BORDER(I) = -MUIND * SWITCH A(I,I+1) WITH A(I,MUIND) T1 = LNZ(XLNZ(I)) LNZ(XLNZ(I)) = LNZ(XLNZ(I)+MUIND-(I+1)) LNZ(XLNZ(I)+MUIND-(I+1)) = T1 * SWITCH A(I+1,I+1) WITH A(MUIND,MUIND) T1 = DIAG(I+1) DIAG(I+1) = DIAG(MUIND) DIAG(MUIND) = T1 * SWITCH THE INNER SQUARE CNT = I+2 CNORECUR DO 2000 J = XLNZ(I+1), XLNZ(I+1)+MUIND-(I+3) T1 = LNZ(J) LNZ(J) = LNZ(XLNZ(CNT)+MUIND-(CNT+1)) LNZ(XLNZ(CNT)+MUIND-(CNT+1)) = T1 CNT = CNT + 1 2000 CONTINUE * SWITCH THE COLUMNS BENEATH ROW MUIND CNT = XLNZ(MUIND) CNORECUR DO 2010 J = XLNZ(I+1)+MUIND-(I+1), XLNZ(I+2)-1 T1 = LNZ(J) LNZ(J) = LNZ(CNT) LNZ(CNT) = T1 CNT = CNT + 1 2010 CONTINUE * SWITCH THE COLUMNS IN THE DELAYED ROWS DO 2020 J = 1, NUMDLY T1 = DELSPC(I-NUMDLY+1,J) DELSPC(I-NUMDLY+1,J) = DELSPC(MUIND-NUMDLY,J) DELSPC(MUIND-NUMDLY,J) = T1 2020 CONTINUE ENDIF * COMPUTE OUR PIVOT COLUMNS THE B-K WAY LAST = I+1 START(I) = XLNZ(I)+1 START(I+1) = XLNZ(I+1) A = DIAG(I) B = LNZ(XLNZ(I)) C = DIAG(I+1) DET = (((A*C)/B)-B)*B DIAG(I) = C/DET DIAG(I+1) = A/DET SUBDAG(I+1) = -B/DET * CALCULATE THE INERTIA IF (DET.LT.0.0D0) THEN INERT = INERT + 1 ELSE * USE THE FORMULA FOR EIGENVALUES OF A 2X2 IF ((A+C-SQRT(4.0D0*B*B+(A-C)*(A-C)))/2.0D0 C .LT.0.0D0) INERT = INERT + 2 ENDIF LNZ(XLNZ(I)) = 0.0D0 CNT = START(I) CNT2 = 1 CNORECUR DO 3000 J = XLNZ(I+1), XLNZ(I+2)-1 TPIV(CNT2) = LNZ(CNT) T2PIV(CNT2) = LNZ(J) LNZ(CNT) = TPIV(CNT2)*DIAG(I)+ C T2PIV(CNT2)*SUBDAG(I+1) LNZ(J) = TPIV(CNT2)*SUBDAG(I+1)+ C T2PIV(CNT2)*DIAG(I+1) CNT = CNT + 1 CNT2 = CNT2 + 1 3000 CONTINUE RIND = XNZSUB(I+1) CNT = 1 CALL FLLVEC(N-LAST,WORKV(LAST+1),0.0D0) DO 3100 J = XLNZ(I+1), XLNZ(I+2)-1 COL = NZSUB(RIND) R2IND = RIND T1 = LNZ(START(I)) T2 = LNZ(START(I+1)) CNORECUR DO 3200 K = CNT, XLNZ(I+2)-XLNZ(I+1) WORKV(NZSUB(R2IND)) = TPIV(K)*T1 + T2PIV(K)*T2 R2IND = R2IND + 1 3200 CONTINUE DIAG(COL) = DIAG(COL) - WORKV(COL) R2IND = XNZSUB(COL) DO 3300 K = XLNZ(COL), XLNZ(COL+1)-1 LNZ(K) = LNZ(K) - WORKV(NZSUB(R2IND)) R2IND = R2IND + 1 3300 CONTINUE RIND = RIND + 1 CNT = CNT + 1 START(I) = START(I) + 1 START(I+1) = START(I+1) + 1 3100 CONTINUE * UPDATE THE DELAYED ROWS NOW DO 3400 J = 1, NUMDLY TPIV(J) = DELSPC(I-NUMDLY,J) T2PIV(J) = DELSPC(I-NUMDLY+1,J) DELSPC(I-NUMDLY,J) = TPIV(J)*DIAG(I) + C T2PIV(J)*SUBDAG(I+1) DELSPC(I-NUMDLY+1,J) = TPIV(J)*SUBDAG(I+1) + C T2PIV(J)*DIAG(I+1) 3400 CONTINUE DO 3410 J = 1, NUMDLY CNT = XNZSUB(I+1) CNT2 = XLNZ(I+1) CNORECUR DO 3420 M = XLNZ(I)+1, XLNZ(I+1)-1 DELSPC(NZSUB(CNT)-NUMDLY,J) = C DELSPC(NZSUB(CNT)-NUMDLY,J) - TPIV(J)*LNZ(M) - C T2PIV(J)*LNZ(CNT2) CNT = CNT + 1 CNT2 = CNT2 + 1 3420 CONTINUE CNORECUR DO 3430 M = 1, J DELSPC(N-(NUMDLY-M),J) = DELSPC(N-(NUMDLY-M),J) C - DELSPC(I-NUMDLY,J)*TPIV(M) - DELSPC(I-NUMDLY+1,J)*T2PIV(M) 3430 CONTINUE 3410 CONTINUE * JUMP TO NEXT ITERATE AFTER THIS IF (QSIZE(PERM(I)).GT.2) THEN QSIZE(PERM(I+2)) = QSIZE(PERM(I))-2 QSIZE(PERM(I)) = 2 ENDIF I = I + 2 IF (I.LE.N) GOTO 100 GOTO 999 ELSE IF (NUMDLY.GE.MAXDLY) THEN IF (.NOT. WARNED) THEN PRINT *,'WARNING: NO ROOM FOR DELAYED PIVOTS' PRINT *,' OCCURRED AT STEP ',I PRINT *,' CHECK ACCURACY OF RESULTS' PRINT *,' INCREASE SPACE FOR PIVOTS' WARNED = .TRUE. ENDIF GOTO 930 ENDIF IF (DEBUG.GT.0) THEN PRINT *,'SWITCH THIS COLUMN TO THE END',I,LAST ENDIF IF (QSIZE(PERM(I)).GT.1) THEN QSIZE(PERM(I+1)) = QSIZE(PERM(I))-1 QSIZE(PERM(I)) = 1 ENDIF BORDER(I) = 0 NUMDLY = NUMDLY + 1 DELAY(NUMDLY) = I * SET UP THE COLUMN IN THE DELAYED ROW SECTION IF (DEBUG.GT.0) THEN PRINT *,'SHOVING INTO DELAYED SECTION',NUMDLY ENDIF CALL FLLVEC(N,DELSPC(1,NUMDLY),0.0D0) DELSPC(N,NUMDLY) = DIAG(I) CNT = XNZSUB(I) DO 5000 J = XLNZ(I),XLNZ(I+1)-1 DELSPC(NZSUB(CNT)-NUMDLY,NUMDLY) = LNZ(J) CNT = CNT + 1 5000 CONTINUE * PERMUTE THE REST OF THE ROWS IN THE DELAYED SECTION DO 5010 J = 1, NUMDLY - 1 DELSPC(N-(NUMDLY-J),NUMDLY) = C DELSPC(I-(NUMDLY-1),J) DO 5020 K = I-NUMDLY+1, N-1 DELSPC(K,J) = DELSPC(K+1,J) 5020 CONTINUE 5010 CONTINUE I = I + 1 IF (I.LE.N) GOTO 100 GOTO 999 ENDIF 930 CONTINUE LAST = I IF (QSIZE(PERM(I)).GT.1) THEN QSIZE(PERM(I+1)) = QSIZE(PERM(I))-1 QSIZE(PERM(I)) = 1 ENDIF ELSE QSIZE(PERM(TLAST+1)) = (I+QSIZE(PERM(I))-1) - TLAST QSIZE(PERM(I)) = TLAST - I + 1 LAST = TLAST ENDIF ENDIF * PUT THE DENSE BACK INTO THE SPARSE DO 301 J = 1, QSIZE(PERM(I)) DIAG(I+J-1) = DENSE(J,J) ISTART = XLNZ(I+J-1) DO 302 K = J+1, QSIZE(PERM(I)) LNZ(ISTART) = DENSE(K,J) ISTART = ISTART + 1 302 CONTINUE 301 CONTINUE * FIND THE STARTING PLACE IN EACH COLUMN DO 299 K = I, LAST START(K) = XLNZ(K)+LAST-K 299 CONTINUE IF (LAST.EQ.I) THEN * UPDATE THE AFFECTED COLUMNS CALL FLLVEC(N-LAST,TPIV(LAST+1),0.0D0) IF (DIAG(LAST).LT.0) INERT = INERT + 1 NZSTRT = XNZSUB(LAST) TD = 1.0D0/DIAG(LAST) DO 4000 J = XLNZ(LAST), XLNZ(LAST+1)-1 T1 = LNZ(J) TPIV(NZSUB(NZSTRT)) = T1 LNZ(J) = T1*TD NZSTRT = NZSTRT + 1 4000 CONTINUE RIND = XNZSUB(LAST) FIRST = XLNZ(LAST) DO 4010 J = XLNZ(LAST), XLNZ(LAST+1)-1 COL = NZSUB(RIND) T1 = LNZ(FIRST) DIAG(COL) = DIAG(COL)-T1*TPIV(COL) R2IND = XNZSUB(COL) DO 4020 K = XLNZ(COL), XLNZ(COL+1)-1 LNZ(K) = LNZ(K) - T1*TPIV(NZSUB(R2IND)) R2IND = R2IND + 1 4020 CONTINUE RIND = RIND + 1 FIRST = FIRST + 1 4010 CONTINUE ELSE DO 300 K = I, LAST IF (DIAG(K).LT.0) INERT = INERT + 1 T1 = 1.0D0/DIAG(K) DO 310 J = START(K), XLNZ(K+1)-1 LNZ(J) = LNZ(J)*T1 310 CONTINUE DO 320 J = K+1, LAST T1 = LNZ(XLNZ(K)+J-K-1) TD = T1*DIAG(K) CNT = START(K) CNORECUR DO 330 M = START(J), XLNZ(J+1)-1 LNZ(M) = LNZ(M) - TD*LNZ(CNT) CNT = CNT + 1 330 CONTINUE 320 CONTINUE 300 CONTINUE * UPDATE THE AFFECTED COLUMNS CALL FLLVEC(N-LAST,T2PIV(LAST+1),0.0D0) RIND = XNZSUB(LAST) NZSTRT = XNZSUB(LAST) NZEND = XNZSUB(LAST)+XLNZ(LAST+1)-XLNZ(LAST)-1 DO 400 J = XLNZ(LAST), XLNZ(LAST+1)-1 * FILL UP THE TEMP ROW CNT2 = I GOTO (425,415,416,417,418) 6-(LAST-I) 425 CONTINUE K = CNT2+5 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-5) T1 = LNZ(M1)*DIAG(K-5) START(K-5) = START(K-5) + 1 M2 = START(K-4) T2 = LNZ(M2)*DIAG(K-4) START(K-4) = START(K-4) + 1 M3 = START(K-3) T3 = LNZ(M3)*DIAG(K-3) START(K-3) = START(K-3) + 1 M4 = START(K-2) T4 = LNZ(M4)*DIAG(K-2) START(K-2) = START(K-2) + 1 M5 = START(K-1) T5 = LNZ(M5)*DIAG(K-1) START(K-1) = START(K-1) + 1 M6 = START(K) T6 = LNZ(M6)*DIAG(K) START(K) = START(K) + 1 DO 427 CNT = NZSTRT, NZEND T2PIV(NZSUB(CNT)) = T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) + T4*LNZ(M4) + T5*LNZ(M5) + T6*LNZ(M6) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 M4 = M4 + 1 M5 = M5 + 1 M6 = M6 + 1 427 CONTINUE GOTO 419 415 CONTINUE K = CNT2+4 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-4) T1 = LNZ(M1)*DIAG(K-4) START(K-4) = START(K-4) + 1 M2 = START(K-3) T2 = LNZ(M2)*DIAG(K-3) START(K-3) = START(K-3) + 1 M3 = START(K-2) T3 = LNZ(M3)*DIAG(K-2) START(K-2) = START(K-2) + 1 M4 = START(K-1) T4 = LNZ(M4)*DIAG(K-1) START(K-1) = START(K-1) + 1 M5 = START(K) T5 = LNZ(M5)*DIAG(K) START(K) = START(K) + 1 DO 424 CNT = NZSTRT, NZEND T2PIV(NZSUB(CNT)) = T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) + T4*LNZ(M4) + T5*LNZ(M5) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 M4 = M4 + 1 M5 = M5 + 1 424 CONTINUE GOTO 419 416 CONTINUE K = CNT2+3 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-3) T1 = LNZ(M1)*DIAG(K-3) START(K-3) = START(K-3) + 1 M2 = START(K-2) T2 = LNZ(M2)*DIAG(K-2) START(K-2) = START(K-2) + 1 M3 = START(K-1) T3 = LNZ(M3)*DIAG(K-1) START(K-1) = START(K-1) + 1 M4 = START(K) T4 = LNZ(M4)*DIAG(K) START(K) = START(K) + 1 DO 423 CNT = NZSTRT, NZEND T2PIV(NZSUB(CNT)) = T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) + T4*LNZ(M4) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 M4 = M4 + 1 423 CONTINUE GOTO 419 417 CONTINUE K = CNT2+2 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-2) T1 = LNZ(M1)*DIAG(K-2) START(K-2) = START(K-2) + 1 M2 = START(K-1) T2 = LNZ(M2)*DIAG(K-1) START(K-1) = START(K-1) + 1 M3 = START(K) T3 = LNZ(M3)*DIAG(K) START(K) = START(K) + 1 DO 422 CNT = NZSTRT, NZEND T2PIV(NZSUB(CNT)) = T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 422 CONTINUE GOTO 419 418 CONTINUE K = CNT2+1 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-1) T1 = LNZ(M1)*DIAG(K-1) START(K-1) = START(K-1) + 1 M2 = START(K) T2 = LNZ(M2)*DIAG(K) START(K) = START(K) + 1 DO 421 CNT = NZSTRT, NZEND T2PIV(NZSUB(CNT)) = T1*LNZ(M1) + T2*LNZ(M2) M1 = M1 + 1 M2 = M2 + 1 421 CONTINUE GOTO 419 419 CONTINUE COL = NZSUB(RIND) DIAG(COL) = DIAG(COL)-T2PIV(COL) R2IND = XNZSUB(COL) DO 450 K = XLNZ(COL), XLNZ(COL+1)-1 LNZ(K) = LNZ(K) - T2PIV(NZSUB(R2IND)) R2IND = R2IND + 1 450 CONTINUE RIND = RIND + 1 NZSTRT = NZSTRT + 1 400 CONTINUE ENDIF DO 990 J = I, I+QSIZE(PERM(I))-1 DIAG(J) = 1.0D0/DIAG(J) 990 CONTINUE * UPDATE VALUES IN DELAYED ROWS DO 5100 K = I, I+QSIZE(PERM(I))-1 DO 5110 J = 1, NUMDLY TRANK = K - NUMDLY IF (DELSPC(TRANK,J).NE.0.0D0) THEN T1 = DELSPC(TRANK,J) DELSPC(TRANK,J) = T1*DIAG(K) CNT = XNZSUB(K) CNORECUR DO 5120 M = XLNZ(K), XLNZ(K+1)-1 DELSPC(NZSUB(CNT)-NUMDLY,J) = C DELSPC(NZSUB(CNT)-NUMDLY,J) - T1*LNZ(M) CNT = CNT + 1 5120 CONTINUE CNORECUR DO 5130 M = 1, J DELSPC(N-(NUMDLY-M),J) = DELSPC(N-(NUMDLY-M),J) - C T1*DELSPC(TRANK,M) 5130 CONTINUE ENDIF 5110 CONTINUE 5100 CONTINUE * UPDATE I AND START LOOP AGAIN (OR EXIT) I = I + QSIZE(PERM(I)) IF (I.LE.N) GOTO 100 999 CONTINUE IF (NUMDLY.LE.0) GOTO 7000 * NOW FINISH UP THE DELAYED ROWS DO 5201 I = 1, NUMDLY DORDER(I) = 0 5201 CONTINUE * THE SUBDIAGONAL FOR THE DELAYED SECTION IS STORED * IN THE LAST COLUMN OF DELSPC DELAY(NUMDLY+1) = 0 I = 1 * LOOP UNTIL I GT THAN NUMDLY 5200 CONTINUE LAMBDA = 0.0D0 IROW = I+1 DO 5210 J = I+1, NUMDLY T1 = ABS(DELSPC(N-(NUMDLY-I),J)) IF (T1.GT.LAMBDA) THEN LAMBDA = T1 IROW = J ENDIF 5210 CONTINUE * DO A 1X1 PIVOT IF POSSIBLE IF (ABS(DELSPC(N-(NUMDLY-I),I)).GT.CVAL*LAMBDA) THEN GOTO 5270 ELSE * SEARCH FOR MU MU = LAMBDA DO 5250 J = I+1, IROW MU = MAX(MU,ABS(DELSPC(N-(NUMDLY-J),IROW))) 5250 CONTINUE DO 5260 J = IROW+1, NUMDLY MU = MAX(MU,ABS(DELSPC(N-(NUMDLY-IROW),J))) 5260 CONTINUE IF (CVAL*(LAMBDA**2).LT.ABS(DELSPC(N-(NUMDLY-I),I)*MU)) C GOTO 5270 GOTO 5280 ENDIF 5270 CONTINUE IF (DELSPC(N-(NUMDLY-I),I).LT.0.0D0) INERT = INERT + 1 DIAG(DELAY(I)) = 1.0D0/DELSPC(N-(NUMDLY-I),I) * NOW ZERO OUT THE SUBDIAGONAL DELSPC(N,I) = 0.0D0 DO 5220 J = I+1, NUMDLY DELSPC(N-(NUMDLY-I),J) = DELSPC(N-(NUMDLY-I),J) * C DIAG(DELAY(I)) 5220 CONTINUE DO 5230 J = I+1, NUMDLY T1 = DELSPC(N-(NUMDLY-I),J)/DIAG(DELAY(I)) DO 5240 K = N-(NUMDLY-I)+1, N-(NUMDLY-J) DELSPC(K,J) = DELSPC(K,J) - C T1*DELSPC(N-(NUMDLY-I),NUMDLY-(N-K)) 5240 CONTINUE 5230 CONTINUE I = I + 1 GOTO 5299 5280 CONTINUE * NEED TO SWITCH HERE IF NECESSARY, AND RECORD ROWI = N-(NUMDLY-I) ROWI1 = ROWI+1 ROWIR = N-(NUMDLY-IROW) IF (IROW.NE.I+1) THEN DORDER(I) = IROW * PERMUTE THE DIAGONAL T1 = DELSPC(ROWI1,I+1) DELSPC(ROWI1,I+1) = DELSPC(ROWIR,IROW) DELSPC(ROWIR,IROW) = T1 * PERMUTE IN COLUMN I T1 = DELSPC(ROWI,I+1) DELSPC(ROWI,I+1) = DELSPC(ROWI,IROW) DELSPC(ROWI,IROW) = T1 * PERMUTE IN THE BOX DO 5400 J = I+2, IROW-1 T1 = DELSPC(ROWI1,J) DELSPC(ROWI1,J) = DELSPC(N-(NUMDLY-J),IROW) DELSPC(N-(NUMDLY-J),IROW) = T1 5400 CONTINUE * PERMUTE THE COLUMNS BELOW DO 5410 J = IROW+1, NUMDLY T1 = DELSPC(ROWI1,J) DELSPC(ROWI1,J) = DELSPC(ROWIR,J) DELSPC(ROWIR,J) = T1 5410 CONTINUE ENDIF IF (DEBUG.GT.0) THEN PRINT *,'PERFORM A 2X2 PIVOT' ENDIF * NOW DO THE PIVOT A = DELSPC(ROWI,I) B = DELSPC(ROWI,I+1) C = DELSPC(ROWI1,I+1) INERT = INERT + 1 DET = (((A*C)/B)-B)*B DIAG(DELAY(I)) = C/DET DIAG(DELAY(I+1)) = A/DET * SUBDAG(DELAY(I+1)) = -B/DET DELSPC(N,I+1) = -B/DET DELSPC(N,I) = 0.0D0 DELSPC(ROWI,I+1) = 0.0D0 CNORECUR DO 5290 J = I+2, NUMDLY TPIV(J) = DELSPC(ROWI,J) T2PIV(J) = DELSPC(ROWI1,J) DELSPC(ROWI,J) = TPIV(J)*DIAG(DELAY(I)) + C T2PIV(J)*DELSPC(N,I+1) DELSPC(ROWI1,J) = TPIV(J)*DELSPC(N,I+1) C + T2PIV(J)*DIAG(DELAY(I+1)) 5290 CONTINUE DO 5295 J = I+2, NUMDLY DO 5296 K = J, NUMDLY DELSPC(N-(NUMDLY-J),K) = DELSPC(N-(NUMDLY-J),K) - C TPIV(J)*DELSPC(ROWI,K) - C T2PIV(J)*DELSPC(ROWI1,K) 5296 CONTINUE 5295 CONTINUE I = I + 2 GOTO 5299 5299 CONTINUE IF (I.LE.NUMDLY) GOTO 5200 7000 CONTINUE IF (DEBUG.GT.0) THEN PRINT *,'THE INERTIA IS ',INERT ENDIF IF (DEBUG.GT.0) THEN ISNODE = 0 DO 2 I = 1, N IF (QSIZE(I).NE.0) ISNODE = ISNODE + 1 2 CONTINUE PRINT *,'THE NUMBER OF SUPERNODES IS ',ISNODE,N/FLOAT(ISNODE) ENDIF * GLUE THE SUPERNODES BACK TOGETHER FOR THE SOLUTION PHASE I = 1 ISNODE = 0 8000 CONTINUE NEXT = I+QSIZE(PERM(I)) IF ((BORDER(NEXT).EQ.I).AND.(BORDER(I).EQ.I)) THEN QSIZE(PERM(I)) = QSIZE(PERM(I))+QSIZE(PERM(NEXT)) GOTO 8000 ELSE I = NEXT ISNODE = ISNODE + 1 ENDIF IF (I.LE.N) GOTO 8000 IF (DEBUG.GT.0) THEN PRINT *,'THE NUMBER OF SUPERNODES IS ',ISNODE,N/FLOAT(ISNODE) ENDIF * PROCESS QSIZE FOR THE SOLVE ROUTINES I = 1 9000 CONTINUE LAST = I + QSIZE(PERM(I)) - 1 CNORECUR DO 9100 J = I+1, LAST QSIZE(PERM(J)) = QSIZE(PERM(I)) 9100 CONTINUE I = LAST + 1 IF (I.LE.N) GOTO 9000 RETURN END C$FORTRAN SPSLVE *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: SPSLVE.MSC * * AUTHOR: MARK JONES * * PURPOSE: PERFORMS FORWARD/BACKWARD SUBSTITUTION AFTER SPARSE * * FACTORIZATION * *********************************************************************** SUBROUTINE ISOLVE(N,X,DIAG,XLNZ,LNZ,XNZSUB,NZSUB,BORDER,SUBDAG, C V,DELAY,DELSPC,DORDER,QSIZE,PERM,WORK1,START,INFLAG) * THE SIZE OF FA INTEGER N * THE SOLUTION VECTOR DOUBLE PRECISION X(*) * THE DIAGONAL OF FA DOUBLE PRECISION DIAG(*) * THE OFF-DIAGONALS OF FA DOUBLE PRECISION LNZ(*) * THE ROW POINTERS INTO FA INTEGER XLNZ(*) * THE COMPRESSED SUBSCRIPT ARRAYS INTEGER NZSUB(*), XNZSUB(*) * THE ORDERING INDUCED BY B-K INTEGER BORDER(*) * SUBDIAGONAL DOUBLE PRECISION SUBDAG(*) * VECTOR CONTAINING THE PERMUTED RHS (WE WILL DESTROY IT) DOUBLE PRECISION V(*) * LIST OF ROWS DELAYED FOR ELIMINATION INTEGER DELAY(*) * SPACE FOR DELAYED ELIMS DOUBLE PRECISION DELSPC(N,*) * PERMUTATION ORDER IN THE DELAYED ROWS INTEGER DORDER(*) * AN ARRAY OF GROUP SIZES INTEGER QSIZE(*) * THE REORDERING VECTOR INTEGER PERM(*) * TEMPORARILY HOLDS UPDATES TO RHS DOUBLE PRECISION WORK1(*) * HOLDS STARTING PLACES INTEGER START(*) * INDICATES THE OPERATIONS TO PERFORM INTEGER INFLAG * INTERNALLY DECLARED VARIABLES * INDICES USED IN LOOPS INTEGER I, J, K, CNT, LAST INTEGER J2, J3, J4, J5, J6 DOUBLE PRECISION T1, T2, T3, T4, T5, T6 INTEGER RIND * NUMBER OF ROWS IN DELAY INTEGER NUMDLY EXTERNAL FLLVEC NUMDLY = 0 I = 1 100 CONTINUE IF (BORDER(I).NE.0) THEN IF (BORDER(I).LT.0) THEN T1 = V(I+1) V(I+1) = V(-BORDER(I)) V(-BORDER(I)) = T1 ENDIF IF (QSIZE(PERM(I)).EQ.1) THEN T1 = V(I) RIND = XNZSUB(I) DO 200 J = XLNZ(I), XLNZ(I+1)-1 V(NZSUB(RIND)) = V(NZSUB(RIND)) - T1*LNZ(J) RIND = RIND + 1 200 CONTINUE * WORK ON DELAYED ROWS DO 210 J = 1, NUMDLY V(DELAY(J)) = V(DELAY(J)) - T1*DELSPC(I-NUMDLY,J) 210 CONTINUE I = I + 1 ELSE * COMPUTE TRIANGLE FIRST LAST = I + QSIZE(PERM(I)) - 1 DO 215 K = I, LAST START(K) = XLNZ(K) T1 = V(K) DO 216 J = K+1, LAST V(J) = V(J) - LNZ(START(K))*T1 START(K) = START(K) + 1 216 CONTINUE 215 CONTINUE CALL FLLVEC(XLNZ(LAST+1)-XLNZ(LAST),WORK1,0.0D0) CNT = I DO 220 K = CNT+5, LAST, 6 T1 = V(K-5) T2 = V(K-4) T3 = V(K-3) T4 = V(K-2) T5 = V(K-1) T6 = V(K) J2 = START(K-4) J3 = START(K-3) J4 = START(K-2) J5 = START(K-1) J6 = START(K) RIND = 1 DO 230 J = START(K-5), XLNZ(K-4)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) + T4*LNZ(J4) + T5*LNZ(J5) + C T6*LNZ(J6) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 J6 = J6 + 1 RIND = RIND + 1 230 CONTINUE CNT = CNT + 6 220 CONTINUE DO 221 K = CNT+4, LAST, 5 T1 = V(K-4) T2 = V(K-3) T3 = V(K-2) T4 = V(K-1) T5 = V(K) J2 = START(K-3) J3 = START(K-2) J4 = START(K-1) J5 = START(K) RIND = 1 DO 231 J = START(K-4), XLNZ(K-3)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) + T4*LNZ(J4) + T5*LNZ(J5) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 RIND = RIND + 1 231 CONTINUE CNT = CNT + 5 221 CONTINUE DO 222 K = CNT+3, LAST, 4 T1 = V(K-3) T2 = V(K-2) T3 = V(K-1) T4 = V(K) J2 = START(K-2) J3 = START(K-1) J4 = START(K) RIND = 1 DO 232 J = START(K-3), XLNZ(K-2)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) + T4*LNZ(J4) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 RIND = RIND + 1 232 CONTINUE CNT = CNT + 4 222 CONTINUE DO 223 K = CNT+2, LAST, 3 T1 = V(K-2) T2 = V(K-1) T3 = V(K) J2 = START(K-1) J3 = START(K) RIND = 1 DO 233 J = START(K-2), XLNZ(K-1)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) J2 = J2 + 1 J3 = J3 + 1 RIND = RIND + 1 233 CONTINUE CNT = CNT + 3 223 CONTINUE DO 224 K = CNT+1, LAST, 2 T1 = V(K-1) T2 = V(K) J2 = START(K) RIND = 1 DO 234 J = START(K-1), XLNZ(K)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) J2 = J2 + 1 RIND = RIND + 1 234 CONTINUE CNT = CNT + 2 224 CONTINUE DO 225 K = CNT, LAST T1 = V(K) RIND = 1 DO 235 J = START(K), XLNZ(K+1)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) RIND = RIND + 1 235 CONTINUE CNT = CNT + 1 225 CONTINUE * WORK ON DELAYED ROWS DO 239 K = I, LAST T1 = V(K) DO 240 J = 1, NUMDLY V(DELAY(J)) = V(DELAY(J)) - T1*DELSPC(K-NUMDLY,J) 240 CONTINUE 239 CONTINUE RIND = XNZSUB(LAST) DO 250 J = 1, XLNZ(LAST+1)-XLNZ(LAST) V(NZSUB(RIND)) = V(NZSUB(RIND)) - WORK1(J) RIND = RIND + 1 250 CONTINUE I = LAST + 1 ENDIF ELSE NUMDLY = NUMDLY + 1 I = I + 1 ENDIF IF (I.LE.N) GOTO 100 * FINISH UP THE DELAYED COLUMNS DO 260 I = 1, NUMDLY IF (DORDER(I).NE.0) THEN T1 = V(DELAY(I+1)) V(DELAY(I+1)) = V(DELAY(DORDER(I))) V(DELAY(DORDER(I))) = T1 ENDIF T1 = V(DELAY(I)) DO 270 J = I+1, NUMDLY V(DELAY(J)) = V(DELAY(J)) - T1*DELSPC(N-(NUMDLY-I),J) 270 CONTINUE 260 CONTINUE DO 300 I = 1, N X(I) = V(I)*DIAG(I) 300 CONTINUE NUMDLY = 0 DO 310 I = 1, N-1 IF (BORDER(I).EQ.0) THEN NUMDLY = NUMDLY + 1 IF (DELAY(NUMDLY+1).NE.0) THEN X(I) = X(I) + V(DELAY(NUMDLY+1))*DELSPC(N,NUMDLY+1) ENDIF ELSE X(I) = X(I) + V(I+1)*SUBDAG(I+1) ENDIF 310 CONTINUE IF (BORDER(1).EQ.0) THEN NUMDLY = 1 ELSE NUMDLY = 0 ENDIF DO 320 I = 2, N IF (BORDER(I).EQ.0) THEN NUMDLY = NUMDLY + 1 IF (NUMDLY.NE.1) THEN X(I) = X(I) + V(DELAY(NUMDLY-1))*DELSPC(N,NUMDLY) ENDIF ELSE X(I) = X(I) + V(I-1)*SUBDAG(I) ENDIF 320 CONTINUE * BACKWARD SOLVE * FINISH UP THE DELAYED COLUMNS DO 600 I = NUMDLY, 1, -1 DO 610 J = I+1, NUMDLY X(DELAY(I)) = X(DELAY(I)) - X(DELAY(J))* C DELSPC(N-(NUMDLY-I),J) 610 CONTINUE IF (DORDER(I).NE.0) THEN T1 = X(DELAY(I+1)) X(DELAY(I+1)) = X(DELAY(DORDER(I))) X(DELAY(DORDER(I))) = T1 ENDIF 600 CONTINUE I = N 400 CONTINUE IF (BORDER(I).EQ.0) THEN NUMDLY = NUMDLY - 1 I = I - 1 ELSE IF (QSIZE(PERM(I)).EQ.1) THEN LAST = I RIND = XNZSUB(I) DO 500 J = XLNZ(I), XLNZ(I+1)-1 X(I) = X(I) - X(NZSUB(RIND))*LNZ(J) RIND = RIND + 1 500 CONTINUE * LET THE DELAYED ROWS WORK DO 550 J = 1, NUMDLY X(I) = X(I) - X(DELAY(J))*DELSPC(I-NUMDLY,J) 550 CONTINUE ELSE LAST = I - QSIZE(PERM(I)) + 1 DO 700 K = LAST, I START(K) = XLNZ(K) + (I-K) 700 CONTINUE RIND = XNZSUB(I) DO 710 J = 1, XLNZ(I+1)-XLNZ(I) WORK1(J) = X(NZSUB(RIND)) RIND = RIND + 1 710 CONTINUE CNT = I DO 720 K = CNT-5, LAST, -6 RIND = 1 J2 = START(K+4) J3 = START(K+3) J4 = START(K+2) J5 = START(K+1) J6 = START(K) DO 730 J = START(K+5), XLNZ(K+6)-1 X(K+5) = X(K+5) - WORK1(RIND)*LNZ(J) X(K+4) = X(K+4) - WORK1(RIND)*LNZ(J2) X(K+3) = X(K+3) - WORK1(RIND)*LNZ(J3) X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J4) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J5) X(K) = X(K) - WORK1(RIND)*LNZ(J6) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 J6 = J6 + 1 RIND = RIND + 1 730 CONTINUE CNT = CNT - 6 720 CONTINUE DO 721 K = CNT-4, LAST, -5 RIND = 1 J2 = START(K+3) J3 = START(K+2) J4 = START(K+1) J5 = START(K) DO 731 J = START(K+4), XLNZ(K+5)-1 X(K+4) = X(K+4) - WORK1(RIND)*LNZ(J) X(K+3) = X(K+3) - WORK1(RIND)*LNZ(J2) X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J3) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J4) X(K) = X(K) - WORK1(RIND)*LNZ(J5) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 RIND = RIND + 1 731 CONTINUE CNT = CNT - 5 721 CONTINUE DO 722 K = CNT-3, LAST, -4 RIND = 1 J2 = START(K+2) J3 = START(K+1) J4 = START(K) DO 732 J = START(K+3), XLNZ(K+4)-1 X(K+3) = X(K+3) - WORK1(RIND)*LNZ(J) X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J2) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J3) X(K) = X(K) - WORK1(RIND)*LNZ(J4) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 RIND = RIND + 1 732 CONTINUE CNT = CNT - 4 722 CONTINUE DO 723 K = CNT-2, LAST, -3 RIND = 1 J2 = START(K+1) J3 = START(K) DO 733 J = START(K+2), XLNZ(K+3)-1 X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J2) X(K) = X(K) - WORK1(RIND)*LNZ(J3) J2 = J2 + 1 J3 = J3 + 1 RIND = RIND + 1 733 CONTINUE CNT = CNT - 3 723 CONTINUE DO 724 K = CNT-1, LAST, -2 RIND = 1 J2 = START(K) DO 734 J = START(K+1), XLNZ(K+2)-1 X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J) X(K) = X(K) - WORK1(RIND)*LNZ(J2) J2 = J2 + 1 RIND = RIND + 1 734 CONTINUE CNT = CNT - 2 724 CONTINUE DO 725 K = CNT, LAST, -1 RIND = 1 DO 735 J = START(K), XLNZ(K+1)-1 X(K) = X(K) - WORK1(RIND)*LNZ(J) RIND = RIND + 1 735 CONTINUE 725 CONTINUE DO 740 K = I, LAST, -1 * LET THE DELAYED ROWS WORK DO 750 J = 1, NUMDLY X(K) = X(K) - X(DELAY(J))*DELSPC(K-NUMDLY,J) 750 CONTINUE 740 CONTINUE * NOW COMPUTE THE TRIANGLE DO 760 K = I, LAST, -1 START(K) = XLNZ(K) RIND = XNZSUB(K) DO 770 J = K+1, I X(K) = X(K) - X(NZSUB(RIND))*LNZ(START(K)) RIND = RIND + 1 START(K) = START(K) + 1 770 CONTINUE 760 CONTINUE ENDIF I = LAST - 1 IF (BORDER(LAST).LT.0) THEN T1 = X(LAST+1) X(LAST+1) = X(-BORDER(LAST)) X(-BORDER(LAST)) = T1 ENDIF ENDIF IF (I.GE.1) GOTO 400 RETURN END C$FORTRAN SMBFCT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: SMBFCT.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: SEE BELOW * *********************************************************************** C----- SUBROUTINE SMBFCT C**************************************************************** C**************************************************************** C********* SMBFCT ..... SYMBOLIC FACTORIZATION ******** C**************************************************************** C**************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS SYMBOLIC FACTORIZATION C ON A PERMUTED LINEAR SYSTEM AND IT ALSO SETS UP THE C COMPRESSED DATA STRUCTURE FOR THE SYSTEM. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. C (PERM, INVP) - THE PERMUTATION VECTOR AND ITS INVERSE. C C UPDATED PARAMETERS - C MAXSUB - SIZE OF THE SUBSCRIPT ARRAY NZSUB. ON RETURN, C IT CONTAINS THE NUMBER OF SUBSCRIPTS USED C C OUTPUT PARAMETERS - C XLNZ - INDEX INTO THE NONZERO STORAGE VECTOR LNZ. C (XNZSUB, NZSUB) - THE COMPRESSED SUBSCRIPT VECTORS. C MAXLNZ - THE NUMBER OF NONZEROS FOUND. C FLAG - ERROR FLAG. POSITIVE VALUE INDICATES THAT. C NZSUB ARRAY IS TOO SMALL. C C WORKING PARAMETERS - C MRGLNK - A VECTOR OF SIZE NEQNS. AT THE KTH STEP, C MRGLNK(K), MRGLNK(MRGLNK(K)) , ......... C IS A LIST CONTAINING ALL THOSE COLUMNS L(*,J) C WITH J LESS THAN K, SUCH THAT ITS FIRST OFF- C DIAGONAL NONZERO IS L(K,J). THUS, THE C NONZERO STRUCTURE OF COLUMN L(*,K) CAN BE FOUND C BY MERGING THAT OF SUCH COLUMNS L(*,J) WITH C THE STRUCTURE OF A(*,K). C RCHLNK - A VECTOR OF SIZE NEQNS. IT IS USED TO ACCUMULATE C THE STRUCTURE OF EACH COLUMN L(*,K). AT THE C END OF THE KTH STEP, C RCHLNK(K), RCHLNK(RCHLNK(K)), ........ C IS THE LIST OF POSITIONS OF NONZEROS IN COLUMN K C OF THE FACTOR L. C MARKER - AN INTEGER VECTOR OF LENGTH NEQNS. IT IS USED C TO TEST IF MASS SYMBOLIC ELIMINATION CAN BE C PERFORMED. THAT IS, IT IS USED TO CHECK WHETHER C THE STRUCTURE OF THE CURRENT COLUMN K BEING C PROCESSED IS COMPLETELY DETERMINED BY THE SINGLE C COLUMN MRGLNK(K). C C**************************************************************** C SUBROUTINE SMBFCT ( NEQNS, XADJ, ADJNCY, PERM, INVP, 1 XLNZ, MAXLNZ, XNZSUB, NZSUB, MAXSUB, 1 RCHLNK, MRGLNK, MARKER, FLAG ) C C**************************************************************** C INTEGER ADJNCY(1), INVP(1), MRGLNK(1), NZSUB(1), 1 PERM(1), RCHLNK(1), MARKER(1) INTEGER XADJ(1), XLNZ(1), XNZSUB(1), 1 FLAG, I, INZ, J, JSTOP, JSTRT, K, KNZ, 1 KXSUB, MRGK, LMAX, M, MAXLNZ, MAXSUB, 1 NABOR, NEQNS, NODE, NP1, NZBEG, NZEND, 1 RCHM, MRKFLG C C**************************************************************** C C ------------------ C INITIALIZATION ... C ------------------ NZBEG = 1 NZEND = 0 XLNZ(1) = 1 DO 100 K = 1, NEQNS MRGLNK(K) = 0 MARKER(K) = 0 100 CONTINUE C -------------------------------------------------- C FOR EACH COLUMN ......... . KNZ COUNTS THE NUMBER C OF NONZEROS IN COLUMN K ACCUMULATED IN RCHLNK. C -------------------------------------------------- NP1 = NEQNS + 1 DO 1500 K = 1, NEQNS KNZ = 0 MRGK = MRGLNK(K) MRKFLG = 0 MARKER(K) = K IF (MRGK .NE. 0 ) MARKER(K) = MARKER(MRGK) XNZSUB(K) = NZEND NODE = PERM(K) JSTRT = XADJ(NODE) JSTOP = XADJ(NODE+1) - 1 IF (JSTRT.GT.JSTOP) GO TO 1500 C ------------------------------------------- C USE RCHLNK TO LINK THROUGH THE STRUCTURE OF C A(*,K) BELOW DIAGONAL C ------------------------------------------- RCHLNK(K) = NP1 DO 300 J = JSTRT, JSTOP NABOR = ADJNCY(J) NABOR = INVP(NABOR) IF ( NABOR .LE. K ) GO TO 300 RCHM = K 200 M = RCHM RCHM = RCHLNK(M) IF ( RCHM .LE. NABOR ) GO TO 200 KNZ = KNZ+1 RCHLNK(M) = NABOR RCHLNK(NABOR) = RCHM IF ( MARKER(NABOR) .NE. MARKER(K) ) MRKFLG = 1 300 CONTINUE C -------------------------------------- C TEST FOR MASS SYMBOLIC ELIMINATION ... C -------------------------------------- LMAX = 0 IF ( MRKFLG .NE. 0 .OR. MRGK .EQ. 0 ) GO TO 350 IF ( MRGLNK(MRGK) .NE. 0 ) GO TO 350 XNZSUB(K) = XNZSUB(MRGK) + 1 KNZ = XLNZ(MRGK+1) - (XLNZ(MRGK) + 1) GO TO 1400 C ----------------------------------------------- C LINK THROUGH EACH COLUMN I THAT AFFECTS L(*,K). C ----------------------------------------------- 350 I = K 400 I = MRGLNK(I) IF (I.EQ.0) GO TO 800 INZ = XLNZ(I+1) - (XLNZ(I)+1) JSTRT = XNZSUB(I) + 1 JSTOP = XNZSUB(I) + INZ IF (INZ.LE.LMAX) GO TO 500 LMAX = INZ XNZSUB(K) = JSTRT C ----------------------------------------------- C MERGE STRUCTURE OF L(*,I) IN NZSUB INTO RCHLNK. C ----------------------------------------------- 500 RCHM = K DO 700 J = JSTRT, JSTOP NABOR = NZSUB(J) 600 M = RCHM RCHM = RCHLNK(M) IF (RCHM.LT.NABOR) GO TO 600 IF (RCHM.EQ.NABOR) GO TO 700 KNZ = KNZ+1 RCHLNK(M) = NABOR RCHLNK(NABOR) = RCHM RCHM = NABOR 700 CONTINUE GO TO 400 C ------------------------------------------------------ C CHECK IF SUBSCRIPTS DUPLICATE THOSE OF ANOTHER COLUMN. C ------------------------------------------------------ 800 IF (KNZ.EQ.LMAX) GO TO 1400 C ----------------------------------------------- C OR IF TAIL OF K-1ST COLUMN MATCHES HEAD OF KTH. C ----------------------------------------------- IF (NZBEG.GT.NZEND) GO TO 1200 I = RCHLNK(K) DO 900 JSTRT=NZBEG,NZEND IF (NZSUB(JSTRT)-I) 900, 1000, 1200 900 CONTINUE GO TO 1200 1000 XNZSUB(K) = JSTRT DO 1100 J=JSTRT,NZEND IF (NZSUB(J).NE.I) GO TO 1200 I = RCHLNK(I) IF (I.GT.NEQNS) GO TO 1400 1100 CONTINUE NZEND = JSTRT - 1 C ---------------------------------------- C COPY THE STRUCTURE OF L(*,K) FROM RCHLNK C TO THE DATA STRUCTURE (XNZSUB, NZSUB). C ---------------------------------------- 1200 NZBEG = NZEND + 1 NZEND = NZEND + KNZ IF (NZEND.GT.MAXSUB) GO TO 1600 I = K DO 1300 J=NZBEG,NZEND I = RCHLNK(I) NZSUB(J) = I MARKER(I) = K 1300 CONTINUE XNZSUB(K) = NZBEG MARKER(K) = K C -------------------------------------------------------- C UPDATE THE VECTOR MRGLNK. NOTE COLUMN L(*,K) JUST FOUND C IS REQUIRED TO DETERMINE COLUMN L(*,J), WHERE C L(J,K) IS THE FIRST NONZERO IN L(*,K) BELOW DIAGONAL. C -------------------------------------------------------- 1400 IF (KNZ.LE.1) GO TO 1500 KXSUB = XNZSUB(K) I = NZSUB(KXSUB) MRGLNK(K) = MRGLNK(I) MRGLNK(I) = K 1500 XLNZ(K+1) = XLNZ(K) + KNZ MAXLNZ = XLNZ(NEQNS) - 1 MAXSUB = XNZSUB(NEQNS) XNZSUB(NEQNS+1) = XNZSUB(NEQNS) FLAG = 0 RETURN C ---------------------------------------------------- C ERROR - INSUFFICIENT STORAGE FOR NONZERO SUBSCRIPTS. C ---------------------------------------------------- 1600 FLAG = 1 RETURN END C$FORTRAN SPELIM *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: SPELIM.MSC * * AUTHOR: MARK JONES * * PURPOSE: REORDER, ETC TO PREPARE FOR SPARSE FACTORIZATION * *********************************************************************** SUBROUTINE SPELIM(N,K,KRP,KCP,M,MRP,MCP, C A,NZSUB,RWSTRT,B,X,SIGMA,INFLAG,FASIZE,FAADDR,FAPTR, C DIAG,SUBDAG,PERM,INVP,XLNZ,XNZSUB,WORK1,WORK2,WORK3,DELAY, C DORDER,PQSIZE,QSIZE,BORDER,INERT,DEBUG,CMDIAG,CMOFF,CMRP,CMCP, C CKDIAG,CKOFF,CKRP,CKCP,UNROLL,INDEF,TMEM, C MAXDLY,INSIZE,INPTR,INADDR) * N IS THE ORDER OF THE MATRIX INTEGER N * K IS A SPARSE MATRIX DOUBLE PRECISION K(*) * KRP CONTAINS THE ROW POINTERS FOR K INTEGER KRP(*) * KCP CONTAINS THE COLUMN NUMBERS FOR K INTEGER KCP(*) * M IS A SPARSE MATRIX DOUBLE PRECISION M(*) * MRP CONTAINS THE ROW POINTERS FOR M INTEGER MRP(*) * MCP CONTAINS THE COLUMN NUMBERS FOR M INTEGER MCP(*) * A IS THE SPACE FOR THE FACTORED VERSION OF (K-SIGMA*M) DOUBLE PRECISION A(*) * WE WILL FORGET ABOUT THE SPACE IN THIS AND USE IT FOR * SUBSCRIPTS IN THE FACTORED MATRIX INTEGER NZSUB(*) * RWSTRT CONTAINS THE COLUMN NUMBER OF (K-SIGMA*M) WHERE * EACH ROW STARTS (NOT USED) INTEGER RWSTRT(*) * B IS THE RIGHT-HAND SIDE DOUBLE PRECISION B(*) * X IS THE SOLUTION TO AX=B DOUBLE PRECISION X(*) * SIGMA IS THE SHIFT BEING USED DOUBLE PRECISION SIGMA * INDICATES WHAT COMBINATION OF FACT, FORWARD AND BACK SOLVE TO DO INTEGER INFLAG * THE AMOUNT OF SPACE ALLOCATED FOR A INTEGER FASIZE * THE ADDRESS OF AND POINTER TO THE SPACE ALLOCATED FOR A INTEGER FAADDR, FAPTR * WORK VECTORS FOR THE ALGORITHM * THE DIAGONAL OF THE D MATRIX DOUBLE PRECISION DIAG(*) * THE OFF-DIAGONAL OF THE D MATRIX DOUBLE PRECISION SUBDAG(*) * THE FOLLOWING VECTORS ARE USED WHEN UPDATING THE A MATRIX * THE PASSING PROGRAM WILL PASS THEM AS ALL DOUBLE PRECISIONS * BUT MANY ARE INTEGERS * THE PERMUTATION VECTOR AND ITS INVERSE INTEGER PERM(*), INVP(*) * POINTERS TO THE NONZEROES INTEGER XLNZ(*) * SUBSCRIPTS INTO THE COMPRESSED STORAGE INTEGER XNZSUB(*) * FLOAT WORK ARRAYS (ALSO USED AS INTEGER ARRAYS) DOUBLE PRECISION WORK1(*), WORK2(*), WORK3(*) * THE LIST OF ROWS DELAYED FOR ELIMINATION INTEGER DELAY(*) * PERMUTATION ORDER IN THE DELAYED ROWS INTEGER DORDER(*) * THE SIZE OF GROUPS OF COLUMNS (SUPER NODES) INTEGER PQSIZE(*) * PERMANENT LIST OF THE SIZE OF GROUPS OF COLUMNS (SUPER NODES) INTEGER QSIZE(*) * KEEPS TRACK OF PERMUTATIONS IN THE FACTORIZATION!! PHASE INTEGER BORDER(*) * THE INERT INTEGER INERT * THE DEBUGGING LEVEL INTEGER DEBUG * THE DIAGONALS OF THE K AND M MATRICES DOUBLE PRECISION CMDIAG(*), CKDIAG(*) * THE FOLLOWING ARE THE K AND M MATRICES STORED BY COLUMNS DOUBLE PRECISION CMOFF(*), CKOFF(*) INTEGER CMRP(*), CKRP(*) INTEGER CMCP(*), CKCP(*) * THE LEVEL OF LOOP UNROLLING INTEGER UNROLL * CALL THE INDEFINITE ROUTINES ?? INTEGER INDEF * TOTAL MEMORY ALLOCATED INTEGER TMEM * THE MAXIMUM NUMBER OF DELAYED PIVOTS THAT CAN BE STORED INTEGER MAXDLY * SIZE OF INDICES INTO FACTORED MATRIX (FOR SPARSE FACTOR) INTEGER INSIZE * OFFSET ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INPTR * ADDRESS INTO INDICES FOR FACTORED MATRIX INTEGER INADDR * SOME INTERNAL VARIABLES * ROW POINTERS AND COLUMN INDICES FOR A=(K-SIGMA*M) * THESE VARIABLES ARE ALLOCATED DYNAMICALLY INTEGER ARP(1), ACP(1) INTEGER ARPADR, ACPADR, ARPPTR, ACPPTR * SPACE TO HOLD THE TEMPORARY ADJACENCY MATRIX INTEGER XADJ(1), ADJNCY(1), NEWADJ(1) INTEGER XADADR, ADJADR, NEWADR INTEGER XADPTR, ADJPTR, NEWPTR * THE MAXIMUM NUMBER OF NONZEROES INTEGER MAXLNZ * THE NUMBER OF SUBSCRIPTS USED INTEGER NOFSUB * RETURN VALUE FROM SMBFCT INTEGER FLAG * INDEX INTO A THAT GIVES LOCATION OF DELSPC INTEGER DLYIND * THE NUMBER OF OPERATIONS DONE IS GSFCT (NOT INSTALLED NOW DOUBLE PRECISION OPS IF (MOD(INFLAG,2).EQ.0) THEN IF (INSIZE.EQ.0) THEN * BUILD THE NON-ZERO STRUCTURE OF A CALL FALLOC(N+1,1,ARP,TMEM,ARPPTR,ARPADR) CALL FALLOC(KRP(N+1)-1+MRP(N+1)-1,1,ACP,TMEM,ACPPTR,ACPADR) CALL FALLOC(2*(KRP(N+1)-1+MRP(N+1)-1),1,NEWADJ,TMEM, C NEWPTR,NEWADR) CALL FALLOC(N+1,1,XADJ,TMEM,XADPTR,XADADR) CALL FALLOC(2*(KRP(N+1)-1+MRP(N+1)-1),1,ADJNCY,TMEM, C ADJPTR,ADJADR) IF (DEBUG.GT.1) THEN CALL L2TMON() ENDIF CALL MAKEA(N,CKRP,CKCP,CMRP,CMCP,ARP(ARPPTR), C ACP(ACPPTR)) IF (DEBUG.GT.1) THEN CALL L2TMOF() PRINT *,'TIME FOR MAKEA IS ',LOCAL2() PRINT *,'THE NUMBER OF NUMZEROES IS ',ARP(ARPPTR+N) ENDIF * GET THE SIZE OF THE FACTOR SPACE AS WELL AS THE ORDERING IF (DEBUG.GT.1) THEN CALL L2TMON() ENDIF CALL REORD(N,ARP(ARPPTR),ACP(ACPPTR),XADJ(XADPTR), C ADJNCY(ADJPTR),NEWADJ(NEWPTR), C PERM,INVP,WORK1,WORK2,WORK3,PQSIZE,NOFSUB) IF (DEBUG.GT.1) THEN CALL L2TMOF() PRINT *,'TIME FOR REORDER IS ',LOCAL2() ENDIF CALL FFREE(2*(KRP(N+1)-1+MRP(N+1)-1),1,TMEM,NEWADR) CALL FFREE(KRP(N+1)-1+MRP(N+1)-1,1,TMEM,ACPADR) CALL FFREE(N+1,1,TMEM,ARPADR) * ALLOCATE SPACE FOR NZSUB CALL FALLOC(NOFSUB,1,NZSUB,TMEM,INPTR,INADDR) INSIZE = NOFSUB IF (DEBUG.GT.1) THEN CALL L2TMON() ENDIF CALL SMBFCT(N,XADJ(XADPTR),ADJNCY(ADJPTR),PERM,INVP,XLNZ, C MAXLNZ,XNZSUB,NZSUB(INPTR),NOFSUB,WORK1,WORK2,WORK3,FLAG) IF (DEBUG.GT.1) THEN CALL L2TMOF() PRINT *,'TIME FOR SMBFCT IS ',LOCAL2() ENDIF CALL FFREE(N+1,1,TMEM,XADADR) CALL FFREE(2*(KRP(N+1)-1+MRP(N+1)-1),1,TMEM,ADJADR) FASIZE = MAXLNZ + MAXDLY*N + N CALL FALLOC(FASIZE,0,A,TMEM,FAPTR,FAADDR) DLYIND = FAPTR + MAXLNZ IF (DEBUG.GT.0) THEN PRINT *,'ALLOCATED ',INSIZE,' FOR SUBSCRIPTS' PRINT *,'ALLOCATED ',MAXLNZ,' FOR NON-ZEROES' PRINT *,'ALLOCATED ',N*MAXDLY,' FOR DELAYED PIVOTS' ENDIF ENDIF DLYIND = FAPTR + XLNZ(N+1)-1 * FILL UP LNZ IF (DEBUG.GT.1) THEN CALL L2TMON() ENDIF CALL FILLNZ(N,CKRP,CKCP,CKOFF,CMRP,CMCP,CMOFF,SIGMA, C CKDIAG,CMDIAG,INVP,DIAG,XLNZ,A(FAPTR),XNZSUB,NZSUB(INPTR)) IF (DEBUG.GT.1) THEN CALL L2TMOF() PRINT *,'TIME FOR FILLNZ IS ',LOCAL2() ENDIF IF (DEBUG.GT.1) THEN CALL L2TMON() ENDIF DO 10 I = 1, N QSIZE(I) = PQSIZE(I) 10 CONTINUE IF (INDEF.EQ.0) THEN CALL PFACT(N,DIAG,XLNZ,A(FAPTR),XNZSUB,NZSUB(INPTR), C WORK1,WORK2,PERM,QSIZE,INERT,WORK3,BORDER, C SUBDAG,DELAY,A(DLYIND),DORDER,DEBUG,MAXDLY,X) IF ((INFLAG.EQ.2).OR.(INFLAG.EQ.4)) THEN DO 100 I = 1, N DIAG(I) = SQRT(DIAG(I)) 100 CONTINUE ENDIF ELSE IF (INDEF.EQ.1) THEN CALL IFACT(N,DIAG,XLNZ,A(FAPTR),XNZSUB,NZSUB(INPTR), C WORK1,WORK2,PERM,QSIZE,INERT,WORK3,BORDER, C SUBDAG,DELAY,A(DLYIND),DORDER,DEBUG,MAXDLY,X) ELSE PRINT *,'GSFCT NOT IN THIS VERSION' STOP * CALL GSFCT (N,XLNZ,A(FAPTR),XNZSUB,NZSUB(INPTR),DIAG, * C WORK1,WORK2,WORK3,FLAG,OPS) * PRINT *,'RETURN VALUE IS ',FLAG,OPS IF (DEBUG.GT.1) THEN CALL L2TMOF() PRINT *,'TIME FOR FACTORIZATION IS ',LOCAL2() ENDIF STOP ENDIF IF (DEBUG.GT.1) THEN CALL L2TMOF() PRINT *,'TIME FOR FACTORIZATION IS ',LOCAL2() ENDIF ENDIF DLYIND = FAPTR + XLNZ(N+1)-1 IF (INFLAG.NE.6) THEN * DO THE SOLVE CALL CPYVEC(N,WORK1,B) CALL PERMUT(N,WORK1,INVP) IF (DEBUG.GT.1) THEN CALL L2TMON() ENDIF IF (INDEF.EQ.0) THEN CALL PSOLVE(N,X,DIAG,XLNZ,A(FAPTR),XNZSUB,NZSUB(INPTR), C BORDER,SUBDAG,WORK1,DELAY,A(DLYIND),DORDER,QSIZE,PERM,WORK2, C WORK3,INFLAG) ELSE CALL ISOLVE(N,X,DIAG,XLNZ,A(FAPTR),XNZSUB,NZSUB(INPTR), C BORDER,SUBDAG,WORK1,DELAY,A(DLYIND),DORDER,QSIZE,PERM,WORK2, C WORK3,INFLAG) ENDIF IF (DEBUG.GT.1) THEN CALL L2TMOF() PRINT *,'TIME FOR SOLVE IS ',LOCAL2() ENDIF CALL PERMUT(N,X,PERM) ENDIF RETURN END * CREATE THE MATRIX (K-SIGMA M) (STRUCTURE ONLY) SUBROUTINE MAKEA(N,KRP,KCP,MRP,MCP,ARP,ACP) * THE ORDER OF THE MATRIX INTEGER N * THE STRUCTURE OF K INTEGER KRP(*), KCP(*) * THE STRUCTURE OF M INTEGER MRP(*), MCP(*) * THE STRUCTURE OF A INTEGER ARP(*), ACP(*) * LOCAL VARIABLES INTEGER I, J INTEGER KSIND, MSIND INTEGER KEIND, MEIND ARP(1) = 1 DO 10 I = 1, N ARP(I+1) = ARP(I) KSIND = KRP(I) MSIND = MRP(I) KEIND = KRP(I+1)-1 MEIND = MRP(I+1)-1 * WORK ON BOTH 20 CONTINUE IF (KSIND.GT.KEIND) GOTO 40 IF (MSIND.GT.MEIND) GOTO 30 IF (KCP(KSIND).EQ.MCP(MSIND)) THEN ACP(ARP(I+1)) = KCP(KSIND) ARP(I+1) = ARP(I+1) + 1 KSIND = KSIND + 1 MSIND = MSIND + 1 ELSE IF (KCP(KSIND).LT.MCP(MSIND)) THEN ACP(ARP(I+1)) = KCP(KSIND) ARP(I+1) = ARP(I+1) + 1 KSIND = KSIND + 1 ELSE ACP(ARP(I+1)) = MCP(MSIND) ARP(I+1) = ARP(I+1) + 1 MSIND = MSIND + 1 ENDIF GOTO 20 * WORK ON K 30 CONTINUE DO 35 J = KSIND, KEIND ACP(ARP(I+1)) = KCP(J) ARP(I+1) = ARP(I+1) + 1 35 CONTINUE GOTO 50 * WORK ON M 40 CONTINUE DO 45 J = MSIND, MEIND ACP(ARP(I+1)) = MCP(J) ARP(I+1) = ARP(I+1) + 1 45 CONTINUE GOTO 50 50 CONTINUE 10 CONTINUE RETURN END * REORDER A BY MINIMUM DEGREE SUBROUTINE REORD(N,ARP,ACP,XADJ,ADJNCY,NEWADJ, C PERM,INVP,WORK1,WORK2,WORK3,QSIZE,NOFSUB) * THE SIZE OF A INTEGER N * POINTERS TO ROWS OF A INTEGER ARP(*) * COLUMN VALUES OF A INTEGER ACP(*) * POINTERS INTO THE ADJ. GRAPH INTEGER XADJ(*) * ADJ. GRAPH AND A COPY INTEGER ADJNCY(*), NEWADJ(*) * THE PERMUTATION SEQUENCE AND ITS INVERSE INTEGER PERM(*), INVP(*) * WORK VECTORS INTEGER WORK1(*), WORK2(*), WORK3(*) * THE SUPERNODE SIZE LIST INTEGER QSIZE(*) * UPPER BOUND ON THE NUMBER OF SUBSCRIPTS INTEGER NOFSUB * LOCALLY DEFINED VARIABLES INTEGER I, J INTEGER IROW DO 10 I = 1, N WORK1(I) = ARP(I+1)-ARP(I) WORK2(I) = 0 10 CONTINUE DO 20 I = 1, N DO 30 J = ARP(I), ARP(I+1)-1 WORK1(ACP(J)) = WORK1(ACP(J)) + 1 30 CONTINUE 20 CONTINUE XADJ(1) = 1 DO 40 I = 1, N XADJ(I+1) = XADJ(I) + WORK1(I) 40 CONTINUE DO 100 I = 1, N DO 150 J = ARP(I), ARP(I+1)-1 IROW = ACP(J) ADJNCY(XADJ(IROW)+WORK2(IROW)) = I WORK2(IROW) = WORK2(IROW) + 1 150 CONTINUE 100 CONTINUE DO 200 I = 1, N DO 250 J = ARP(I), ARP(I+1)-1 ADJNCY(XADJ(I)+WORK2(I)) = ACP(J) WORK2(I) = WORK2(I) + 1 250 CONTINUE 200 CONTINUE DO 300 I = 1, XADJ(N+1)-1 NEWADJ(I) = ADJNCY(I) 300 CONTINUE MAXINT = 2 900 CONTINUE NOMAX = MAXINT MAXINT = MAXINT*2 IF (MAXINT.GT.0) GOTO 900 MAXINT = NOMAX NOMAX = -NOMAX IDELTA = 0 * HERE IS THE OLD CALL TO GENMMD FROM THE TESTBED VERSION * CALL GENMMD(N,XADJ,NEWADJ,INVP,PERM,IDELTA,WORK1,QSIZE, * C WORK2, WORK3, MAXINT, NOFSUB) * WE PRESS ACP AND ARP INTO SERVICE AS WORK VECTORS BECAUSE * THEY ARE NO LONGER NEEDED CALL GENQMD(N,XADJ,NEWADJ,PERM,INVP,WORK1,WORK2,WORK3,ARP, C QSIZE,ACP,NOFSUB) * FIX UP QSIZE TO LOOK LIKE WE EXPECT I = 1 500 CONTINUE DO 510 J = I+1, I+QSIZE(PERM(I))-1 QSIZE(PERM(J)) = 0 510 CONTINUE I = I + QSIZE(PERM(I)) IF (I.LT.N) GOTO 500 RETURN END * FILL UP THE LNZ MATRIX SUBROUTINE FILLNZ(N,KRP,KCP,KOFF,MRP,MCP,MOFF,SIGMA, C K,M,INVP,DIAG,XLNZ,LNZ,XNZSUB,NZSUB) * THE ORDER OF THE MATRIX INTEGER N * ROW POINTERS INTO K INTEGER KRP(*) * COLUMN VALUES OF K INTEGER KCP(*) * NON-ZEROES OF K DOUBLE PRECISION KOFF(*) * ROW POINTERS INTO M INTEGER MRP(*) * COLUMN VALUES OF M INTEGER MCP(*) * NON-ZEROES OF M DOUBLE PRECISION MOFF(*) * THE SHIFT VALUE DOUBLE PRECISION SIGMA * DIAGONALS OF EACH MATRIX DOUBLE PRECISION K(*), M(*) * THE INVERSE OF THE PERMUTATION VECTOR INTEGER INVP(*) * THE DIAGONAL OF THE FACTORED MATRIX DOUBLE PRECISION DIAG(*) * POINTERS INTO LNZ INTEGER XLNZ(*) * THE NONZEROES OF THE FACTORED MATRIX DOUBLE PRECISION LNZ(*) * COMPRESSED SUBSCRIPT STORAGE INTEGER XNZSUB(*), NZSUB(*) * INTERNALLY DECLARED VARIABLES INTEGER I, J, IERR, ICOUNT, ISUB, JSUB INTEGER KSIND, MSIND DOUBLE PRECISION VALUE CALL FLLVEC(XLNZ(N+1)-1,LNZ,0.0D0) CALL FLLVEC(N,DIAG,0.0D0) DO 10 I = 1, N VALUE = K(I)-SIGMA*M(I) ISUB = INVP(I) DIAG(ISUB) = VALUE KSIND = KRP(I) MSIND = MRP(I) KEIND = KRP(I+1)-1 MEIND = MRP(I+1)-1 * WORK ON BOTH 20 CONTINUE IF (KSIND.GT.KEIND) GOTO 40 IF (MSIND.GT.MEIND) GOTO 30 IF (KCP(KSIND).EQ.MCP(MSIND)) THEN ISUB = INVP(MCP(MSIND)) JSUB = INVP(I) VALUE = KOFF(KSIND)-SIGMA*MOFF(MSIND) KSIND = KSIND + 1 MSIND = MSIND + 1 ELSE IF (KCP(KSIND).LT.MCP(MSIND)) THEN ISUB = INVP(KCP(KSIND)) JSUB = INVP(I) VALUE = KOFF(KSIND) KSIND = KSIND + 1 ELSE ISUB = INVP(MCP(MSIND)) JSUB = INVP(I) VALUE = -SIGMA*MOFF(MSIND) MSIND = MSIND + 1 ENDIF IF ( ISUB .GT. JSUB ) GO TO 100 ITEMP = ISUB ISUB = JSUB JSUB = ITEMP 100 CONTINUE LSUB = XNZSUB(JSUB) LSTRT = XLNZ(JSUB) LSTOP = XLNZ(JSUB+1) - 1 C ------------------------------------------ C THE COMPONENT LIES IN THE LOWER TRIANGULAR C PORTION. C ------------------------------------------ DO 200 L = LSTRT, LSTOP IF ( ISUB .EQ. NZSUB(LSUB) ) GO TO 300 LSUB = LSUB + 1 200 CONTINUE 300 CONTINUE LNZ(L) = VALUE GOTO 20 * WORK ON K 30 CONTINUE DO 35 J = KSIND, KEIND VALUE = KOFF(J) ISUB = INVP(KCP(J)) JSUB = INVP(I) IF ( ISUB .GT. JSUB ) GO TO 110 ITEMP = ISUB ISUB = JSUB JSUB = ITEMP 110 CONTINUE LSUB = XNZSUB(JSUB) LSTRT = XLNZ(JSUB) LSTOP = XLNZ(JSUB+1) - 1 DO 210 L = LSTRT, LSTOP IF ( ISUB .EQ. NZSUB(LSUB) ) GO TO 310 LSUB = LSUB + 1 210 CONTINUE 310 CONTINUE LNZ(L) = VALUE 35 CONTINUE GOTO 50 * WORK ON M 40 CONTINUE DO 45 J = MSIND, MEIND VALUE= -SIGMA*MOFF(J) ISUB = INVP(MCP(J)) JSUB = INVP(I) IF ( ISUB .GT. JSUB ) GO TO 120 ITEMP = ISUB ISUB = JSUB JSUB = ITEMP 120 CONTINUE LSUB = XNZSUB(JSUB) LSTRT = XLNZ(JSUB) LSTOP = XLNZ(JSUB+1) - 1 DO 220 L = LSTRT, LSTOP IF ( ISUB .EQ. NZSUB(LSUB) ) GO TO 320 LSUB = LSUB + 1 220 CONTINUE 320 CONTINUE LNZ(L) = VALUE 45 CONTINUE GOTO 50 50 CONTINUE 10 CONTINUE RETURN END * APPLY A PERMUTATION TO A VECTOR SUBROUTINE PERMUT(N,REVVEC,PERM) * THE SIZE OF THE VECTOR INTEGER N * THE VECTOR THE PERMUTATION IS BEING APPLIED TO DOUBLE PRECISION REVVEC(*) * THE PERMUTATION VECTOR INTEGER PERM(*) * INTERNAL VARIABLES INTEGER I, NEXT, NOW DOUBLE PRECISION TEMP, SAVE DO 10 I = 1, N IF (PERM(I).LT.0) GOTO 10 NEXT = PERM(I) SAVE = REVVEC(I) 20 CONTINUE IF (PERM(NEXT).LT.0) GOTO 10 TEMP = SAVE SAVE = REVVEC(NEXT) REVVEC(NEXT) = TEMP NOW = NEXT NEXT = PERM(NOW) PERM(NOW) = -NEXT GOTO 20 10 CONTINUE DO 30 I = 1, N PERM(I) = - PERM(I) 30 CONTINUE RETURN END C$FORTRAN SPFACT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: SPFACT.MSC * * AUTHOR: MARK JONES * * PURPOSE: SPARSE INDEFINITE FACTORIZATION OR POSITIVE DEFINITE * * FACTORIZATION, DEPENDING ON IF SPBK IS SPECIFIED AT * * COMPILATION. * *********************************************************************** * SPARSE INDEFINITE FACTORIZATION WITH COMPRESSED STORAGE SUBROUTINE PFACT(N,DIAG,XLNZ,LNZ,XNZSUB,NZSUB,TPIV,T2PIV, C PERM,QSIZE,INERT,START,BORDER,SUBDAG, C DELAY,DELSPC,DORDER,DEBUG,MAXDLY,WORKV) * THE SIZE OF FA INTEGER N * THE DIAGONAL OF FA DOUBLE PRECISION DIAG(*) * THE OFF-DIAGONALS OF FA DOUBLE PRECISION LNZ(*) * THE ROW POINTERS INTO FA INTEGER XLNZ(*) * THE COMPRESSED SUBSCRIPT ARRAYS INTEGER NZSUB(*), XNZSUB(*) * TEMPORARILY HOLDS THE PIVOT COLUMN * T2PIV ALSO HOLDS THE RATIO OF A(I)/A(I,I) IN THE PIVOT * COMBINING PHASE DOUBLE PRECISION TPIV(*), T2PIV(*) * THE PERMUTATION VECTOR INTEGER PERM(*) * THE SUPERNODE SIZE VECTOR INTEGER QSIZE(*) * THE INERTIA OF A INTEGER INERT * HOLDS STARTING PLACES INSIDE VECTORS INTEGER START(*) * THE ORDERING INDUCED BY B-K INTEGER BORDER(*) * THE SUBDIAGONAL DOUBLE PRECISION SUBDAG(*) * A LIST OF ROWS DELAYED TO THE END INTEGER DELAY(*) * SPACE FOR THE DELAYED ROWS DOUBLE PRECISION DELSPC(N,*) * PERMUTATION VECTOR IN THE DELAYED ROWS INTEGER DORDER(*) * THE LEVEL OF DEBUGGING DESIRED INTEGER DEBUG * THE MAXIMUM NUMBER OF DELAYED PIVOTS THAT CAN BE STORED INTEGER MAXDLY * A DOUBLE PRECISION WORK VECTOR DOUBLE PRECISION WORKV(*) * INTERNALLY DECLARED VARIABLES * NUMBER OF ROWS DELAYED INTEGER NUMDLY * TEMPORARY VALUES INTEGER I, J, K, M, CNT, FIRST, LAST, CNT2 INTEGER COL, RIND, R2IND, IROW, ISTART INTEGER ROWI, ROWI1, ROWIR INTEGER NZSTRT, NZEND, TQSIZE * ARE WE FINISHED TRYING TO COMBINE PIVOT COLUMNS LOGICAL DONE * USE TO COMPUTE THE LEGAL GROWTH RATE DOUBLE PRECISION CRTSUM, CRIT, GRATE, CVAL * USE IN PERFORMING UPDATE OF REMAINING NON-ZEROES INTEGER M1, M2, M3, M4, M5, M6 DOUBLE PRECISION T1, TD, T2, T3, T4, T5, T6 * TEMPORARY VALUE INTEGER LENGTH, TLAST * A TEMPORARY HOLDING PLACE FOR THE PIVOT BLOCK * THE NUMBER OF SUPER NODES INTEGER ISNODE * THE MINIMUM MU THAT IS NEEDED TO GET A 1X1 PIVOT INTEGER MUIND * INDICATES THAT A SWITCH OF ROWS(AND COLUMNS) IS NEEDED LOGICAL SWITCH * USE IN COMPUTING THE 2X2 PIVOTS DOUBLE PRECISION A,B,C,MU,DET, MUMIN * A TEMPORARY VALUE FOR K INTEGER TRANK * THE MAXIMUM VALUE IN A PIVOT COLUMN DOUBLE PRECISION LAMBDA * HAS A WARNING ALREADY BEEN ISSUED IF THE SPACE FOR DELAYED * PIVOTS HAS BEEN EXCEEDED LOGICAL WARNED * INTEGER FUNCTIONS INTEGER IGETMX EXTERNAL FLLVEC, IGETMX WARNED = .FALSE. IF (DEBUG.GT.0) THEN ISNODE = 0 DO 1 I = 1, N IF (QSIZE(I).NE.0) ISNODE = ISNODE + 1 1 CONTINUE PRINT *,'THE NUMBER OF SUPERNODES IS ',ISNODE,N/FLOAT(ISNODE) ENDIF INERT = 0 I = 1 100 CONTINUE LAST = I-1+QSIZE(PERM(I)) IF (LAST.EQ.I) THEN * UPDATE THE AFFECTED COLUMNS CALL FLLVEC(N-LAST,TPIV(LAST+1),0.0D0) IF (DIAG(LAST).LT.0) INERT = INERT + 1 NZSTRT = XNZSUB(LAST) TD = 1.0D0/DIAG(LAST) DO 4000 J = XLNZ(LAST), XLNZ(LAST+1)-1 T1 = LNZ(J) TPIV(NZSUB(NZSTRT)) = T1 LNZ(J) = T1*TD NZSTRT = NZSTRT + 1 4000 CONTINUE RIND = XNZSUB(LAST) FIRST = XLNZ(LAST) DO 4010 J = XLNZ(LAST), XLNZ(LAST+1)-1 COL = NZSUB(RIND) T1 = LNZ(FIRST) DIAG(COL) = DIAG(COL)-T1*TPIV(COL) R2IND = XNZSUB(COL) DO 4020 K = XLNZ(COL), XLNZ(COL+1)-1 LNZ(K) = LNZ(K) - T1*TPIV(NZSUB(R2IND)) R2IND = R2IND + 1 4020 CONTINUE RIND = RIND + 1 FIRST = FIRST + 1 4010 CONTINUE ELSE * COMPUTE THE PIVOT COLUMN(S) DO 301 J = I, LAST IF (DIAG(J).LT.0) INERT = INERT + 1 T1 = 1.0D0/DIAG(J) DO 302 K = XLNZ(J), XLNZ(J+1)-1 LNZ(K) = LNZ(K)*T1 302 CONTINUE START(J) = XLNZ(J) DO 303 K = J+1, LAST T1 = LNZ(START(J)) TD = T1*DIAG(J) DIAG(K) = DIAG(K) - T1*TD START(J) = START(J) + 1 CNT = START(J) CNORECUR DO 304 M = XLNZ(K), XLNZ(K+1)-1 LNZ(M) = LNZ(M) - TD*LNZ(CNT) CNT = CNT + 1 304 CONTINUE 303 CONTINUE 301 CONTINUE * UPDATE THE AFFECTED COLUMNS CALL FLLVEC(N-LAST,T2PIV(LAST+1),0.0D0) RIND = XNZSUB(LAST) NZSTRT = XNZSUB(LAST) NZEND = XNZSUB(LAST)+XLNZ(LAST+1)-XLNZ(LAST)-1 DO 400 J = XLNZ(LAST), XLNZ(LAST+1)-1 * FILL UP THE TEMP ROW CALL FLLVEC(XLNZ(I+1)-START(I),TPIV,0.0D0) CNT2 = I DO 426 K = CNT2+5, LAST, 6 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-5) T1 = LNZ(M1)*DIAG(K-5) START(K-5) = START(K-5) + 1 M2 = START(K-4) T2 = LNZ(M2)*DIAG(K-4) START(K-4) = START(K-4) + 1 M3 = START(K-3) T3 = LNZ(M3)*DIAG(K-3) START(K-3) = START(K-3) + 1 M4 = START(K-2) T4 = LNZ(M4)*DIAG(K-2) START(K-2) = START(K-2) + 1 M5 = START(K-1) T5 = LNZ(M5)*DIAG(K-1) START(K-1) = START(K-1) + 1 M6 = START(K) T6 = LNZ(M6)*DIAG(K) START(K) = START(K) + 1 DO 427 CNT = 1, LENGTH TPIV(CNT) = TPIV(CNT) + T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) + T4*LNZ(M4) + T5*LNZ(M5) + T6*LNZ(M6) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 M4 = M4 + 1 M5 = M5 + 1 M6 = M6 + 1 427 CONTINUE CNT2 = CNT2 + 6 426 CONTINUE DO 414 K = CNT2+4, LAST, 5 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-4) T1 = LNZ(M1)*DIAG(K-4) START(K-4) = START(K-4) + 1 M2 = START(K-3) T2 = LNZ(M2)*DIAG(K-3) START(K-3) = START(K-3) + 1 M3 = START(K-2) T3 = LNZ(M3)*DIAG(K-2) START(K-2) = START(K-2) + 1 M4 = START(K-1) T4 = LNZ(M4)*DIAG(K-1) START(K-1) = START(K-1) + 1 M5 = START(K) T5 = LNZ(M5)*DIAG(K) START(K) = START(K) + 1 DO 424 CNT = 1, LENGTH TPIV(CNT) = TPIV(CNT) + T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) + T4*LNZ(M4) + T5*LNZ(M5) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 M4 = M4 + 1 M5 = M5 + 1 424 CONTINUE CNT2 = CNT2 + 5 414 CONTINUE DO 413 K = CNT2+3, LAST, 4 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-3) T1 = LNZ(M1)*DIAG(K-3) START(K-3) = START(K-3) + 1 M2 = START(K-2) T2 = LNZ(M2)*DIAG(K-2) START(K-2) = START(K-2) + 1 M3 = START(K-1) T3 = LNZ(M3)*DIAG(K-1) START(K-1) = START(K-1) + 1 M4 = START(K) T4 = LNZ(M4)*DIAG(K) START(K) = START(K) + 1 DO 423 CNT = 1, LENGTH TPIV(CNT) = TPIV(CNT) + T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) + T4*LNZ(M4) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 M4 = M4 + 1 423 CONTINUE CNT2 = CNT2 + 4 413 CONTINUE DO 412 K = CNT2+2, LAST, 3 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-2) T1 = LNZ(M1)*DIAG(K-2) START(K-2) = START(K-2) + 1 M2 = START(K-1) T2 = LNZ(M2)*DIAG(K-1) START(K-1) = START(K-1) + 1 M3 = START(K) T3 = LNZ(M3)*DIAG(K) START(K) = START(K) + 1 DO 422 CNT = 1, LENGTH TPIV(CNT) = TPIV(CNT) + T1*LNZ(M1) + T2*LNZ(M2) C + T3*LNZ(M3) M1 = M1 + 1 M2 = M2 + 1 M3 = M3 + 1 422 CONTINUE CNT2 = CNT2 + 3 412 CONTINUE DO 411 K = CNT2+1, LAST, 2 LENGTH = XLNZ(K+1)-START(K) M1 = START(K-1) T1 = LNZ(M1)*DIAG(K-1) START(K-1) = START(K-1) + 1 M2 = START(K) T2 = LNZ(M2)*DIAG(K) START(K) = START(K) + 1 DO 421 CNT = 1, LENGTH TPIV(CNT) = TPIV(CNT) + T1*LNZ(M1) + T2*LNZ(M2) M1 = M1 + 1 M2 = M2 + 1 421 CONTINUE CNT2 = CNT2 + 2 411 CONTINUE DO 410 K = CNT2, LAST FIRST = START(K) START(K) = START(K) + 1 T1 = LNZ(FIRST)*DIAG(K) CNT = 1 DO 420 M = FIRST, XLNZ(K+1)-1 TPIV(CNT) = TPIV(CNT) + T1*LNZ(M) CNT = CNT + 1 420 CONTINUE 410 CONTINUE CNT = 1 DO 440 K = NZSTRT, NZEND T2PIV(NZSUB(K)) = TPIV(CNT) CNT = CNT + 1 440 CONTINUE COL = NZSUB(RIND) DIAG(COL) = DIAG(COL)-T2PIV(COL) R2IND = XNZSUB(COL) DO 450 K = XLNZ(COL), XLNZ(COL+1)-1 LNZ(K) = LNZ(K) - T2PIV(NZSUB(R2IND)) R2IND = R2IND + 1 450 CONTINUE RIND = RIND + 1 NZSTRT = NZSTRT + 1 400 CONTINUE ENDIF DO 990 J = I, I+QSIZE(PERM(I))-1 DIAG(J) = 1.0D0/DIAG(J) 990 CONTINUE * UPDATE I AND START LOOP AGAIN (OR EXIT) I = I + QSIZE(PERM(I)) IF (I.LE.N) GOTO 100 999 CONTINUE IF (DEBUG.GT.0) THEN PRINT *,'THE INERTIA IS ',INERT ENDIF * PROCESS QSIZE FOR THE SOLVE ROUTINES I = 1 9000 CONTINUE LAST = I + QSIZE(PERM(I)) - 1 CNORECUR DO 9100 J = I+1, LAST QSIZE(PERM(J)) = QSIZE(PERM(I)) 9100 CONTINUE I = LAST + 1 IF (I.LE.N) GOTO 9000 RETURN END C$FORTRAN SPSLVE *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: SPSLVE.MSC * * AUTHOR: MARK JONES * * PURPOSE: PERFORMS FORWARD/BACKWARD SUBSTITUTION AFTER SPARSE * * FACTORIZATION * *********************************************************************** SUBROUTINE PSOLVE(N,X,DIAG,XLNZ,LNZ,XNZSUB,NZSUB,BORDER,SUBDAG, C V,DELAY,DELSPC,DORDER,QSIZE,PERM,WORK1,START,INFLAG) * THE SIZE OF FA INTEGER N * THE SOLUTION VECTOR DOUBLE PRECISION X(*) * THE DIAGONAL OF FA DOUBLE PRECISION DIAG(*) * THE OFF-DIAGONALS OF FA DOUBLE PRECISION LNZ(*) * THE ROW POINTERS INTO FA INTEGER XLNZ(*) * THE COMPRESSED SUBSCRIPT ARRAYS INTEGER NZSUB(*), XNZSUB(*) * THE ORDERING INDUCED BY B-K INTEGER BORDER(*) * SUBDIAGONAL DOUBLE PRECISION SUBDAG(*) * VECTOR CONTAINING THE PERMUTED RHS (WE WILL DESTROY IT) DOUBLE PRECISION V(*) * LIST OF ROWS DELAYED FOR ELIMINATION INTEGER DELAY(*) * SPACE FOR DELAYED ELIMS DOUBLE PRECISION DELSPC(N,*) * PERMUTATION ORDER IN THE DELAYED ROWS INTEGER DORDER(*) * AN ARRAY OF GROUP SIZES INTEGER QSIZE(*) * THE REORDERING VECTOR INTEGER PERM(*) * TEMPORARILY HOLDS UPDATES TO RHS DOUBLE PRECISION WORK1(*) * HOLDS STARTING PLACES INTEGER START(*) * INDICATES THE OPERATIONS TO PERFORM INTEGER INFLAG * INTERNALLY DECLARED VARIABLES * INDICES USED IN LOOPS INTEGER I, J, K, CNT, LAST INTEGER J2, J3, J4, J5, J6 DOUBLE PRECISION T1, T2, T3, T4, T5, T6 INTEGER RIND * NUMBER OF ROWS IN DELAY INTEGER NUMDLY EXTERNAL FLLVEC IF (INFLAG.LE.3) THEN NUMDLY = 0 I = 1 100 CONTINUE IF (QSIZE(PERM(I)).EQ.1) THEN T1 = V(I) RIND = XNZSUB(I) DO 200 J = XLNZ(I), XLNZ(I+1)-1 V(NZSUB(RIND)) = V(NZSUB(RIND)) - T1*LNZ(J) RIND = RIND + 1 200 CONTINUE I = I + 1 ELSE * COMPUTE TRIANGLE FIRST LAST = I + QSIZE(PERM(I)) - 1 DO 215 K = I, LAST START(K) = XLNZ(K) T1 = V(K) DO 216 J = K+1, LAST V(J) = V(J) - LNZ(START(K))*T1 START(K) = START(K) + 1 216 CONTINUE 215 CONTINUE CALL FLLVEC(XLNZ(LAST+1)-XLNZ(LAST),WORK1,0.0D0) CNT = I DO 220 K = CNT+5, LAST, 6 T1 = V(K-5) T2 = V(K-4) T3 = V(K-3) T4 = V(K-2) T5 = V(K-1) T6 = V(K) J2 = START(K-4) J3 = START(K-3) J4 = START(K-2) J5 = START(K-1) J6 = START(K) RIND = 1 DO 230 J = START(K-5), XLNZ(K-4)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) + T4*LNZ(J4) + T5*LNZ(J5) + C T6*LNZ(J6) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 J6 = J6 + 1 RIND = RIND + 1 230 CONTINUE CNT = CNT + 6 220 CONTINUE DO 221 K = CNT+4, LAST, 5 T1 = V(K-4) T2 = V(K-3) T3 = V(K-2) T4 = V(K-1) T5 = V(K) J2 = START(K-3) J3 = START(K-2) J4 = START(K-1) J5 = START(K) RIND = 1 DO 231 J = START(K-4), XLNZ(K-3)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) + T4*LNZ(J4) + T5*LNZ(J5) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 RIND = RIND + 1 231 CONTINUE CNT = CNT + 5 221 CONTINUE DO 222 K = CNT+3, LAST, 4 T1 = V(K-3) T2 = V(K-2) T3 = V(K-1) T4 = V(K) J2 = START(K-2) J3 = START(K-1) J4 = START(K) RIND = 1 DO 232 J = START(K-3), XLNZ(K-2)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) + T4*LNZ(J4) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 RIND = RIND + 1 232 CONTINUE CNT = CNT + 4 222 CONTINUE DO 223 K = CNT+2, LAST, 3 T1 = V(K-2) T2 = V(K-1) T3 = V(K) J2 = START(K-1) J3 = START(K) RIND = 1 DO 233 J = START(K-2), XLNZ(K-1)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) + T3*LNZ(J3) J2 = J2 + 1 J3 = J3 + 1 RIND = RIND + 1 233 CONTINUE CNT = CNT + 3 223 CONTINUE DO 224 K = CNT+1, LAST, 2 T1 = V(K-1) T2 = V(K) J2 = START(K) RIND = 1 DO 234 J = START(K-1), XLNZ(K)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) + C T2*LNZ(J2) J2 = J2 + 1 RIND = RIND + 1 234 CONTINUE CNT = CNT + 2 224 CONTINUE DO 225 K = CNT, LAST T1 = V(K) RIND = 1 DO 235 J = START(K), XLNZ(K+1)-1 WORK1(RIND) = WORK1(RIND) + T1*LNZ(J) RIND = RIND + 1 235 CONTINUE CNT = CNT + 1 225 CONTINUE RIND = XNZSUB(LAST) DO 250 J = 1, XLNZ(LAST+1)-XLNZ(LAST) V(NZSUB(RIND)) = V(NZSUB(RIND)) - WORK1(J) RIND = RIND + 1 250 CONTINUE I = LAST + 1 ENDIF IF (I.LE.N) GOTO 100 ENDIF DO 300 I = 1, N X(I) = V(I)*DIAG(I) 300 CONTINUE IF ((INFLAG.LE.1).OR.(INFLAG.EQ.4).OR.(INFLAG.EQ.5)) THEN * BACKWARD SOLVE I = N 400 CONTINUE IF (QSIZE(PERM(I)).EQ.1) THEN LAST = I RIND = XNZSUB(I) DO 500 J = XLNZ(I), XLNZ(I+1)-1 X(I) = X(I) - X(NZSUB(RIND))*LNZ(J) RIND = RIND + 1 500 CONTINUE ELSE LAST = I - QSIZE(PERM(I)) + 1 DO 700 K = LAST, I START(K) = XLNZ(K) + (I-K) 700 CONTINUE RIND = XNZSUB(I) DO 710 J = 1, XLNZ(I+1)-XLNZ(I) WORK1(J) = X(NZSUB(RIND)) RIND = RIND + 1 710 CONTINUE CNT = I DO 720 K = CNT-5, LAST, -6 RIND = 1 J2 = START(K+4) J3 = START(K+3) J4 = START(K+2) J5 = START(K+1) J6 = START(K) DO 730 J = START(K+5), XLNZ(K+6)-1 X(K+5) = X(K+5) - WORK1(RIND)*LNZ(J) X(K+4) = X(K+4) - WORK1(RIND)*LNZ(J2) X(K+3) = X(K+3) - WORK1(RIND)*LNZ(J3) X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J4) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J5) X(K) = X(K) - WORK1(RIND)*LNZ(J6) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 J6 = J6 + 1 RIND = RIND + 1 730 CONTINUE CNT = CNT - 6 720 CONTINUE DO 721 K = CNT-4, LAST, -5 RIND = 1 J2 = START(K+3) J3 = START(K+2) J4 = START(K+1) J5 = START(K) DO 731 J = START(K+4), XLNZ(K+5)-1 X(K+4) = X(K+4) - WORK1(RIND)*LNZ(J) X(K+3) = X(K+3) - WORK1(RIND)*LNZ(J2) X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J3) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J4) X(K) = X(K) - WORK1(RIND)*LNZ(J5) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 J5 = J5 + 1 RIND = RIND + 1 731 CONTINUE CNT = CNT - 5 721 CONTINUE DO 722 K = CNT-3, LAST, -4 RIND = 1 J2 = START(K+2) J3 = START(K+1) J4 = START(K) DO 732 J = START(K+3), XLNZ(K+4)-1 X(K+3) = X(K+3) - WORK1(RIND)*LNZ(J) X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J2) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J3) X(K) = X(K) - WORK1(RIND)*LNZ(J4) J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 RIND = RIND + 1 732 CONTINUE CNT = CNT - 4 722 CONTINUE DO 723 K = CNT-2, LAST, -3 RIND = 1 J2 = START(K+1) J3 = START(K) DO 733 J = START(K+2), XLNZ(K+3)-1 X(K+2) = X(K+2) - WORK1(RIND)*LNZ(J) X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J2) X(K) = X(K) - WORK1(RIND)*LNZ(J3) J2 = J2 + 1 J3 = J3 + 1 RIND = RIND + 1 733 CONTINUE CNT = CNT - 3 723 CONTINUE DO 724 K = CNT-1, LAST, -2 RIND = 1 J2 = START(K) DO 734 J = START(K+1), XLNZ(K+2)-1 X(K+1) = X(K+1) - WORK1(RIND)*LNZ(J) X(K) = X(K) - WORK1(RIND)*LNZ(J2) J2 = J2 + 1 RIND = RIND + 1 734 CONTINUE CNT = CNT - 2 724 CONTINUE DO 725 K = CNT, LAST, -1 RIND = 1 DO 735 J = START(K), XLNZ(K+1)-1 X(K) = X(K) - WORK1(RIND)*LNZ(J) RIND = RIND + 1 735 CONTINUE 725 CONTINUE * NOW COMPUTE THE TRIANGLE DO 760 K = I, LAST, -1 START(K) = XLNZ(K) RIND = XNZSUB(K) DO 770 J = K+1, I X(K) = X(K) - X(NZSUB(RIND))*LNZ(START(K)) RIND = RIND + 1 START(K) = START(K) + 1 770 CONTINUE 760 CONTINUE ENDIF I = LAST - 1 IF (I.GE.1) GOTO 400 ENDIF RETURN END C$FORTRAN TIMEIT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: TIMEIT.MSC * * AUTHOR: MARK JONES * * PURPOSE: NON-MACHINE DEPENDENT TIMING, SEE BELOW * *********************************************************************** ****************************************************************** * THREE TIMING FUNCTIONS MUST BE SUPPLIED. EACH SHOULD RETURN * AN INTEGER VALUE WHICH IS A NUMBER OF MILLISECONDS. * 1) TIME1() - TOTAL USER MODE TIME * 2) TIME2() - TOTAL SYSTEM MODE TIME * 3) TIME3() - TOTAL DOUBLE PRECISION TIME ****************************************************************** * THE CALLABLE FUNCTIONS AND PROCEDURES IN THIS MODULE ARE * ITIME() - INITIALIZES THE TIMING ROUTINES * TIMON() - SETS THE CLOCK GOING * TIMOFF() - TURNS THE CLOCK OFF * UTIME() - TOTAL USER MODE TIME IN LANZ * STIME() - TOTAL SYSTEM MODE TIME IN LANZ * RTIME() - TOTAL DOUBLE PRECISION TIME IN LANZ * L2TMON() - SET A LOCAL CLOCK GOING * L2TMOF() - TURN A LOCAL CLOCK OFF * LOCAL2() - GET THE TOTAL USER LOCAL TIME * LTIMON() - SET ANOTHER LOCAL CLOCK ON * LTIMOF() - SET ANOTHER LOCAL CLOCK OFF * LOCALT() - GET THE TOTAL USER LOCAL TIME FROM THIS CLOCK * RTIMON() - SET LOCAL DOUBLE PRECISION CLOCK ON * RTIMOF() - SET LOCAL DOUBLE PRECISION CLOCK OFF * LOCALR() - GET THE TOTAL USER LOCAL TIME FROM THIS CLOCK ****************************************************************** INTEGER FUNCTION UTIME() INTEGER TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON COMMON /TIMBLK/ TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON UTIME = TOTTIM RETURN END INTEGER FUNCTION RTIME() INTEGER TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON COMMON /TIMBLK/ TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON RTIME = TRTIME RETURN END INTEGER FUNCTION STIME() INTEGER TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON COMMON /TIMBLK/ TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON STIME = TSTIME RETURN END SUBROUTINE ITIME() INTEGER TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON COMMON /TIMBLK/ TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON INTEGER TIME1, TIME2, TIME3 EXTERNAL TIME1, TIME2, TIME3 INTEGER TO * MAKE SOME CALLS TO ACCESS THE TIMER FOR THE FIRST TIME TO = TIME1() TO = TIME2() TO = TIME3() TOTTIM = 0 TSTIME = 0 TRTIME = 0 GON = 0 RETURN END SUBROUTINE TIMON() INTEGER TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON COMMON /TIMBLK/ TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON INTEGER TIME1, TIME2, TIME3 EXTERNAL TIME1, TIME2, TIME3 CTIME = TIME1() CSTIME = TIME2() CRTIME = TIME3() GON = 1 RETURN END SUBROUTINE TIMOFF() INTEGER TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON COMMON /TIMBLK/ TSTIME,TRTIME,CSTIME,CTIME,CRTIME,TOTTIM,GON INTEGER TIME1, TIME2, TIME3 EXTERNAL TIME1, TIME2, TIME3 IF (GON.EQ.1) THEN TOTTIM = TOTTIM + TIME1()-CTIME TSTIME = TSTIME + TIME2()-CSTIME TRTIME = TRTIME + TIME3()-CRTIME GON = 0 ENDIF RETURN END SUBROUTINE LTIMON() INTEGER LELAPS, LCUR COMMON /TBLK2/ LELAPS, LCUR INTEGER TIME1 EXTERNAL TIME1 LCUR = TIME1() LELAPS = 0 RETURN END SUBROUTINE LTIMOF() INTEGER LELAPS, LCUR COMMON /TBLK2/ LELAPS, LCUR INTEGER TIME1 EXTERNAL TIME1 LELAPS = TIME1() - LCUR + LELAPS RETURN END INTEGER FUNCTION LOCALT() INTEGER LELAPS, LCUR COMMON /TBLK2/ LELAPS, LCUR LOCALT = LELAPS RETURN END SUBROUTINE L2TMON() INTEGER LELAPS, LCUR COMMON /TBLK3/ LELAPS, LCUR INTEGER TIME1 EXTERNAL TIME1 LCUR = TIME1() LELAPS = 0 RETURN END SUBROUTINE L2TMOF() INTEGER LELAPS, LCUR COMMON /TBLK3/ LELAPS, LCUR INTEGER TIME1 EXTERNAL TIME1 LELAPS = TIME1() - LCUR + LELAPS RETURN END INTEGER FUNCTION LOCAL2() INTEGER LELAPS, LCUR COMMON /TBLK3/ LELAPS, LCUR LOCAL2 = LELAPS RETURN END SUBROUTINE RTIMON() INTEGER LELAPS, LCUR COMMON /TBLK4/ LELAPS, LCUR INTEGER TIME3 EXTERNAL TIME3 LCUR = TIME3() LELAPS = 0 RETURN END SUBROUTINE RTIMOF() INTEGER LELAPS, LCUR COMMON /TBLK4/ LELAPS, LCUR INTEGER TIME3 EXTERNAL TIME3 LELAPS = TIME3() - LCUR + LELAPS RETURN END INTEGER FUNCTION LOCALR() INTEGER LELAPS, LCUR COMMON /TBLK4/ LELAPS, LCUR LOCALR = LELAPS RETURN END C$FORTRAN TQL2 *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: TQL2.MSC * * AUTHOR: RECEIVED FROM NETLIB * * PURPOSE: FINDS ALL THE EIGENVALUES AND EIGENVECTORS OF A * * TRIDIAGONAL MATRIX * *********************************************************************** SUBROUTINE TQL2(NM,N,D,E,Z,IERR) C INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR DOUBLE PRECISION D(N),E(N),Z(NM,N) DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND C WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1. C C E HAS BEEN DESTROYED. C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C F = 0.0D0 TST1 = 0.0D0 E(N) = 0.0D0 C DO 240 L = 1, N J = 0 H = DABS(D(L)) + DABS(E(L)) IF (TST1 .LT. H) TST1 = H C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... DO 110 M = L, N TST2 = TST1 + DABS(E(M)) IF (TST2 .EQ. TST1) GO TO 120 C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP .......... 110 CONTINUE C 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 C .......... FORM SHIFT .......... L1 = L + 1 L2 = L1 + 1 G = D(L) P = (D(L1) - G) / (2.0D0 * E(L)) R = PYTHAG(P,1.0D0) D(L) = E(L) / (P + DSIGN(R,P)) D(L1) = E(L) * (P + DSIGN(R,P)) DL1 = D(L1) H = G - D(L) IF (L2 .GT. N) GO TO 145 C DO 140 I = L2, N 140 D(I) = D(I) - H C 145 F = F + H C .......... QL TRANSFORMATION .......... P = D(M) C = 1.0D0 C2 = C EL1 = E(L1) S = 0.0D0 MML = M - L C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML C3 = C2 C2 = C S2 = S I = M - II G = C * E(I) H = C * P R = PYTHAG(P,E(I)) E(I+1) = S * R S = E(I) / R C = P / R P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) C .......... FORM VECTOR .......... DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE C 200 CONTINUE C P = -S * S2 * C3 * EL1 * E(L) / DL1 E(L) = S * P D(L) = C * P TST2 = TST1 + DABS(E(L)) IF (TST2 .GT. TST1) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN END DOUBLE PRECISION FUNCTION PYTHAG(A,B) DOUBLE PRECISION A,B C C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW C DOUBLE PRECISION P,R,S,T,U P = DMAX1(DABS(A),DABS(B)) IF (P .EQ. 0.0D0) GO TO 20 R = (DMIN1(DABS(A),DABS(B))/P)**2 10 CONTINUE T = 4.0D0 + R IF (T .EQ. 4.0D0) GO TO 20 S = R/T U = 1.0D0 + 2.0D0*S P = U*P R = (S/U)**2 * R GO TO 10 20 PYTHAG = P RETURN END C$FORTRAN TRANSM *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: TRANS.MSC * * AUTHOR: MARK JONES * * PURPOSE: TRANSPOSES A AND PUTS IT IN TA * *********************************************************************** * A ROUTINE THAT PUTS THE SPARSE TRANSPOSE IN TA SUBROUTINE TRANSM(N,ADIAG,A,ARP,ACP,TA,TARP,TACP,WORKV,DEBUG) * THE ORDER OF A INTEGER N * THE DIAGONAL OF A DOUBLE PRECISION ADIAG(*) * THE OFF-DIAGONAL OF A DOUBLE PRECISION A(*) * THE ROW POINTERS OF A INTEGER ARP(*) * THE COLUMN INDICES OF A INTEGER ACP(*) * THE TRANSPOSE OF A DOUBLE PRECISION TA(*) * THE ROW POINTERS OF TA INTEGER TARP(*) * THE COLUMN INDICES OF TA INTEGER TACP(*) * AN INTEGER WORK VECTOR INTEGER WORKV(*) * THE DEBUGGING VALUE INTEGER DEBUG * INTERNAL VARIABLES * COUNT AND TEMPORARY VARIABLES INTEGER I, J INTEGER ICX, TICX INTEGER ISTART, ITEMP * CALCULATE THE TRANSPOSES OF K AND M DO 10 I = 1, N TARP(I) = 1 10 CONTINUE DO 20 I = 1, ARP(N+1)-1 TARP(ACP(I)) = TARP(ACP(I)) + 1 20 CONTINUE ISTART = 1 DO 30 I = 1, N ITEMP = TARP(I) TARP(I) = ISTART ISTART = ISTART + ITEMP 30 CONTINUE TARP(N+1) = ISTART IF (DEBUG.GT.0) THEN PRINT *,'ASIZE = ',ARP(N+1)-1 PRINT *,'ATSIZE = ',TARP(N+1)-1 ENDIF DO 40 I = 1, N WORKV(I) = 1 TA(TARP(I)) = ADIAG(I) TACP(TARP(I)) = I 40 CONTINUE DO 50 I = 1, N CNORECUR DO 60 J = ARP(I), ARP(I+1)-1 TICX = ACP(J) ICX = TARP(TICX) + WORKV(TICX) WORKV(TICX) = WORKV(TICX) + 1 TACP(ICX) = I TA(ICX) = A(J) 60 CONTINUE 50 CONTINUE RETURN END C$FORTRAN VBLDNZ *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: VBLDNZ.MSC * * AUTHOR: E. L. POOLE * * MODIFIED BY: MARK JONES * * PURPOSE: LDL(T) FACTORIZATION OF A SYMMETRIC POSITIVE DEFINITE * * MATRIX STORED IN SKYLINE FORM * *********************************************************************** SUBROUTINE VBLDNZ(A,ALTH,AD,ROWPTR,ROWLEN,N,NOPS,NNEG,NROLL) * ARGUMENTS PASSED IN INTEGER N,ALTH,NOPS,NNEG,NROLL DOUBLE PRECISION + A(*),AD(*) INTEGER ROWPTR(*),ROWLEN(*) * VARIABLES DECLARED LOCALLY INTEGER K,I,J DOUBLE PRECISION ZERO INTEGER IST1, IST2, IST3, IST4, IST5, IST6 COMMON /TTT/ IST1,IST2,IST3,IST4,IST5,IST6 DOUBLE PRECISION XM1,XM2,XM3,XM4,XM5,XM6 DOUBLE PRECISION TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6 COMMON /TTT/ TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6 * THE DECLARATIONS THAT GENE LEFT OUT DOUBLE PRECISION TEMP INTEGER KLTH, LASTK, N0S, LTH, ICT, KCOLM, KST, KLAST, C ICOLM, ILTH, KDX, IT1, IDX ZERO=0.0D0 C ***** THIS REVISED LDL FACTORIZATION ROUTINE HAS LOOP UNROLLING LEVEL C ***** NROLL AND STORES DIAGONAL MATRIX D IN A SINGLE VECTOR, AD() C ***** THE DIAGONAL ELEMENTS OF A, THE INPUT MATRIX, ARE ALSO STORED C ***** AT THE BEGINNING OF EACH COLUMN TO MAINTAIN COMPATIBILITY C ***** WITH EARLIER VERSIONS C ***** THIS VERSION ALSO INCLUDES ZERO CHECKING BEFORE COLUMNS ARE C ***** UPDATED C ***** FINALLY, THE DIAGONAL MATRIX D IS STORED AS D**-1 NNEG=0 K=1 9990 CONTINUE C SUBROUTINE TOP(A,AD,TEMP,ROWPTR,ROWLEN,N,NROLL,NNEG,K,NOPS) CALL TOP(A,AD,TEMP,ROWPTR,ROWLEN,N,NROLL,NNEG,K,NOPS) C SWEEP THROUGH MATRIX UPDATING COLUMNS WITH 6 MULTIPLIERS AT A TIME C KLTH=ROWLEN(K) LASTK=K+KLTH-1 C *** NOW UPDATE COLUMNS OF INPUT MATRIX USING NROLL COLUMNS *** C *** OF L 26 CONTINUE C *** POINT TO ELEMENT IN THE NROLL COLMUNS OF L *** C *** THAT IS IN ROW J *** LIST1=IST1+1 LIST2=IST2+1 LIST3=IST3+1 LIST4=IST4+1 LIST5=IST5+1 LIST6=IST6 DO 260 J=K+NROLL,LASTK N0S=0 LTH=LASTK-J+1 IF (LTH.GT.0) THEN C *** BEGIN COUNT THE NUMBER OF ZERO MULTIPLIERS *** IF (A(LIST1).EQ.ZERO) THEN IF (A(LIST2).EQ.ZERO) THEN IF (A(LIST3).EQ.ZERO) THEN IF (A(LIST4).EQ.ZERO) THEN IF (A(LIST5).EQ.ZERO) THEN IF (A(LIST6).EQ.ZERO) THEN N0S=NROLL END IF END IF END IF END IF END IF END IF C *** END COUNT THE NUMBER OF ZERO MULTIPLIERS *** C *** BEGIN UPDATE IF AT LEAST 1 MULTIPLIER IS NON-ZERO IF (N0S.LT.NROLL) THEN XM1=A(LIST1)*TEMP1 XM2=A(LIST2)*TEMP2 XM3=A(LIST3)*TEMP3 XM4=A(LIST4)*TEMP4 XM5=A(LIST5)*TEMP5 XM6=A(LIST6)*TEMP6 AD(J)=AD(J) - A(LIST1)*XM1 + - A(LIST2)*XM2 + - A(LIST3)*XM3 + - A(LIST4)*XM4 + - A(LIST5)*XM5 + - A(LIST6)*XM6 ICT=1 CNORECUR DO 2600 I=ROWPTR(J)+1,ROWPTR(J)+LTH-1 A(I)=A(I) - A(LIST1+ICT)*XM1 + - A(LIST2+ICT)*XM2 + - A(LIST3+ICT)*XM3 + - A(LIST4+ICT)*XM4 + - A(LIST5+ICT)*XM5 + - A(LIST6+ICT)*XM6 ICT=ICT+1 2600 CONTINUE END IF C *** END OF COLUMN J UPDATE ***** END IF C *** MOVE POINTERS TO THE NEXT ROW IN THE NROLL COLUMNS OF L *** LIST1=LIST1+1 LIST2=LIST2+1 LIST3=LIST3+1 LIST4=LIST4+1 LIST5=LIST5+1 LIST6=LIST6+1 260 CONTINUE 9992 CONTINUE K=K+NROLL IF (N-K.GT.10) GOTO 9990 C WRITE(6,*) ' BEFORE END NOPS, K' C WRITE(6,600) NOPS, K DO 30 KCOLM=K,N-1 KST=ROWPTR(KCOLM) KLTH=ROWLEN(KCOLM) KLAST=KCOLM+KLTH-1 C **** FINISH DIAGONAL ELEMENT OF COLUMN KCOLM OF L TEMP1=AD(KCOLM) IF (AD(KCOLM).LT.0.0) NNEG=NNEG+1 AD(KCOLM)=1.0/AD(KCOLM) C **** FINISH COLUMN KCOLM OF L DO 301 I=KST+1,KST+KLTH-1 301 A(I)=A(I)*AD(KCOLM) C **** UPDATE APPROPRIATE COLUMNS OF MATRIX USING COLUMN KCOLM DO 302 ICOLM=KCOLM+1,KLAST ILTH=KLAST-ICOLM+1 KDX=KST+ICOLM-KCOLM IT1=KDX XM1=A(KDX)*TEMP1 AD(ICOLM)=AD(ICOLM)-A(KDX)*XM1 CDIR$ NOVECTOR DO 302 IDX=ROWPTR(ICOLM)+1,ROWPTR(ICOLM)+ILTH-1 IT1=IT1+1 A(IDX)= A(IDX)-XM1*A(IT1) 302 CONTINUE 30 CONTINUE IF (AD(N).LT.0.0) NNEG=NNEG+1 AD(N)=1.0/AD(N) CDIR$ VECTOR C WRITE(6,*) ' AT END NOPS, K' C WRITE(6,600) NOPS, K 600 FORMAT(5X,5(I8,1X)) RETURN END SUBROUTINE TOP(A,AD,TEMP,ROWPTR,ROWLEN,N,NROLL,NNEG,K,NOPS) DOUBLE PRECISION + A(*),AD(*),TEMP INTEGER ROWPTR(*),ROWLEN(*),N,NROLL,NNEG,K,NOPS INTEGER IST1, IST2, IST3, IST4, IST5, IST6 COMMON /TTT/ IST1,IST2,IST3,IST4,IST5,IST6 DOUBLE PRECISION TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6 COMMON /TTT/ TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6 * SOME LOCAL DECLARATIONS INTEGER I, ICT, N0S DOUBLE PRECISION TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ DOUBLE PRECISION TK,TL,TM,TN,TO,TP,TQ,TR,TS,TT,TU * SOME OF THE VALUES IN THE PIVOT BLOCK * A * B C * D E F * G H I J * K L M N O * P Q R S T U IST1=ROWPTR(K)+1 IST2=ROWPTR(K+1)+1 IST3=ROWPTR(K+2)+1 IST4=ROWPTR(K+3)+1 IST5=ROWPTR(K+4)+1 IST6=ROWPTR(K+5)+1 C **** THIS ROUTINE COMPUTES NROLL COLUMNS OF THE CHOLESKI FACTOR L C **** BEGINNING WITH COLUMN K C **** IMPORTANT NOTE !!! THIS ROUTINE ASSUMES THAT THE DIAGONAL C **** OF THE INPUT MATRIX IS STORED IN ARRAY AD() BUT IT IS ALSO C **** STORED AS THE FIRST ELEMENT IN EACH COLUMN OF THE MATRIX STORED C **** IN ARRAY A(). THE DIAGONAL FOR COLUMN K IS STORED IN C **** AD(K) AS WELL AS A(ROWPTR(K)) . THIS DUPLICATION IS ALLOWED C **** FOR COMPATIBILITY WITH OTHER SOLVERS THAT DO NOT STORE C **** AD() IN AN ARRAY BY ITSELF. C *** BEGIN COLUMN K *** IF (AD(K).LT.0.0) NNEG=NNEG+1 * FOR ONE TEMP1 = AD(K) AD(K)=1.0/AD(K) * FOR TWO TB=A(IST1) A(IST1) = TB*AD(K) AD(K+1)=AD(K+1) - A(IST1)*TB IF (AD(K+1).LT.0.0) NNEG=NNEG+1 TEMP2=AD(K+1) AD(K+1)=1.0/AD(K+1) * FOR THREE TD=A(IST1+1) A(IST1+1) = TD * AD(K) TE=A(IST2) - TB*A(IST1+1) A(IST2)=TE*AD(K+1) AD(K+2)=AD(K+2) - A(IST1+1)*TD - A(IST2)*TE IF (AD(K+2).LT.0.0) NNEG=NNEG+1 TEMP3=AD(K+2) AD(K+2)=1.0/AD(K+2) * FOR FOUR TG=A(IST1+2) A(IST1+2) = TG * AD(K) TH=A(IST2+1) - TB*A(IST1+2) A(IST2+1)=TH*AD(K+1) TI=A(IST3) - TD*A(IST1+2) - TE*A(IST2+1) A(IST3)=TI*AD(K+2) AD(K+3)=AD(K+3) - A(IST1+2)*TG - A(IST2+1)*TH - A(IST3)*TI IF (AD(K+3).LT.0.0) NNEG=NNEG+1 TEMP4=AD(K+3) AD(K+3)=1.0/AD(K+3) * FOR FIVE TK=A(IST1+3) A(IST1+3) = TK * AD(K) TL=A(IST2+2) - TB*A(IST1+3) A(IST2+2)=TL*AD(K+1) TM=A(IST3+1) - TD*A(IST1+3) - TE*A(IST2+2) A(IST3+1)=TM*AD(K+2) TN=A(IST4) - TG*A(IST1+3) - TH*A(IST2+2) - TI*A(IST3+1) A(IST4)=TN*AD(K+3) AD(K+4)=AD(K+4) - A(IST1+3)*TK - A(IST2+2)*TL - A(IST3+1)*TM + - A(IST4)*TN IF (AD(K+4).LT.0.0) NNEG=NNEG+1 TEMP5=AD(K+4) AD(K+4)=1.0/AD(K+4) * FOR SIX TP=A(IST1+4) A(IST1+4) = TP * AD(K) TQ=A(IST2+3) - TB*A(IST1+4) A(IST2+3)=TQ*AD(K+1) TR=A(IST3+2) - TD*A(IST1+4) - TE*A(IST2+3) A(IST3+2)=TR*AD(K+2) TS=A(IST4+1) - TG*A(IST1+4) - TH*A(IST2+3) - TI*A(IST3+2) A(IST4+1)=TS*AD(K+3) TT=A(IST5) - TK*A(IST1+4) - TL*A(IST2+3) - TM*A(IST3+2) + - TN*A(IST4+1) A(IST5)=TT*AD(K+4) AD(K+5)=AD(K+5) - A(IST1+4)*TP - A(IST2+3)*TQ - A(IST3+2)*TR + - A(IST4+1)*TS - A(IST5)*TT IF (AD(K+5).LT.0.0) NNEG=NNEG+1 TEMP6=AD(K+5) AD(K+5)=1.0/AD(K+5) I2 = IST2+4 I3 = IST3+3 I4 = IST4+2 I5 = IST5+1 I6 = IST6 CNORECUR DO 10 I=IST1+5,IST1+ROWLEN(K)-2 A(I) = A(I) * AD(K) A(I2)=(A(I2) - TB*A(I))*AD(K+1) A(I3)=(A(I3) - TD*A(I) - TE*A(I2))*AD(K+2) A(I4)=(A(I4) - TG*A(I) - TH*A(I2) - TI*A(I3))*AD(K+3) A(I5)=(A(I5) - TK*A(I) - TL*A(I2) - TM*A(I3) - TN*A(I4)) C *AD(K+4) A(I6)=(A(I6) - TP*A(I) - TQ*A(I2) - TR*A(I3) - TS*A(I4) C -TT*A(I5))*AD(K+5) I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 I6 = I6 + 1 10 CONTINUE C *** END COLUMN K *** IST1 = IST1 + 4 IST2 = IST2 + 3 IST3 = IST3 + 2 IST4 = IST4 + 1 RETURN END C$FORTRAN VBSOLVERS *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: VBLDS6.MSC * * AUTHOR: E. L. POOLE AND A. L. OVERMAN * * FURTHER MODIFIED BY MARK JONES * * PURPOSE: SOLVE THE LOWER AND UPPER TRIANGULAR SYSTEMS WHICH * * RESULTS FROM THE FACTORIZED SKYLINE BANDED MATRIX * * STORED IN SKYLINE FORM * *********************************************************************** SUBROUTINE VBLDS(A,ALTH,AD,CPTR,CLEN,N,B,NOPSS,SOPER) INTEGER ALTH,N,NOPSS,SOPER, ISHIFT DOUBLE PRECISION A(ALTH),B(N),AD(N) INTEGER CPTR(N),CLEN(N),ROW,COLM C **** THIS LDL SOLVER ASSUMES THAT L IS UNIT LOWER TRIANGULAR C **** AND THE DIAGONAL MATRIX D IS STORED IN ARRAY AD() C **** IN INVERTED FORM (D**-1.) C **** THE COEFFICIENTS OF L ARE STORED BY COLUMNS C **** WITH ARRAY A() CONTAINING THE COEFFICIENTS C ***** ARRAY CPTR() CONTAINS THE STARTING LOCATION OF THE C **** COEFFICIENTS FOR EACH COLUMN C **** ARRAY CLEN() GIVES THE NUMBER OF NON-ZERO COEFFICIENTS C **** IN EACH COLUMN C **** NOTE THAT THE DIAGONAL ELEMENTS OF L ARE ALLOCATED IN THE C **** DATA STRUCTURE BUT NOT USED BY THIS SOLVER. THIS IS BECAUSE C **** AN LL CHOLESKI SOLVER IS ALSO USED WHICH STORES THE DIAGONAL C **** ELEMENTS ALONG WITH THE COLUMNS RATHER THAN SEPARATELY C **** SOLVE LY=B NOPSS=0 C WRITE(6,*) ' L AT BEGINNING OF VBLD1 ' C DO 61 COLM=1,N C B(COLM)=1.0/30. C WRITE(6,6001) COLM, AD(COLM) C ISHIFT=CPTR(COLM)-COLM C DO 610 ROW=COLM+1,COLM+CLEN(COLM)-1 C IF (A(ISHIFT+ROW).NE.0.0) WRITE(6,6002) ROW,ISHIFT+ROW, C + A(ISHIFT+ROW) C610 CONTINUE C61 CONTINUE C6001 FORMAT(1X,' D( ',I5,')=',G14.6) C6002 FORMAT(5X,' ROW=',I5,' INDEX=',I7,' COEF=',G15.7) IF ((SOPER.EQ.0).OR.(SOPER.EQ.1)) THEN DO 1 COLM=1,N ISHIFT=CPTR(COLM)-COLM C$DIR NO_RECURRENCE DO 10 ROW=COLM+1,COLM+CLEN(COLM)-1 B(ROW)=B(ROW)-A(ISHIFT+ROW)*B(COLM) 10 CONTINUE NOPSS=NOPSS+(CLEN(COLM)-1)*2 1 CONTINUE ENDIF C WRITE(6,*) ' B() AFTER FORWARD SOLVE' C DO 166 COLM=1,N C166 WRITE(6,6003) COLM,B(COLM) C6003 FORMAT(1X,'B(',I5,')=',G15.7) C **** SOLVE Y = D**-1 Y DO 2 ROW=1,N 2 B(ROW)=AD(ROW)*B(ROW) C **** SOLVE L(TRANSP)X=Y IF ((SOPER.EQ.0).OR.(SOPER.EQ.2)) THEN DO 3 ROW=N-1,1,-1 ISHIFT=CPTR(ROW)-ROW C$DIR NO_RECURRENCE DO 30 COLM=ROW+1,ROW+CLEN(ROW)-1 B(ROW)=B(ROW)-A(ISHIFT+COLM)*B(COLM) 30 CONTINUE NOPSS=NOPSS+2*(CLEN(ROW)-1) 3 CONTINUE ENDIF C WRITE(6,*) ' B() AFTER BACK SOLVE' C DO 366 COLM=1,N C366 WRITE(6,6003) COLM,B(COLM) RETURN END SUBROUTINE VBLDSZ(A,ALTH,AD,CPTR,CLEN,N,B,NOPSS,SOPER) INTEGER ALTH,N,NOPSS,SOPER,ISHIFT DOUBLE PRECISION A(ALTH),B(N),AD(N) INTEGER CPTR(N),CLEN(N),ROW,COLM C **** THIS LDL SOLVER ASSUMES THAT L IS UNIT LOWER TRIANGULAR C **** AND THE DIAGONAL MATRIX D IS STORED IN ARRAY AD() C **** IN INVERTED FORM (D**-1.) C **** THE COEFFICIENTS OF L ARE STORED BY COLUMNS C **** WITH ARRAY A() CONTAINING THE COEFFICIENTS C ***** ARRAY CPTR() CONTAINS THE STARTING LOCATION OF THE C **** COEFFICIENTS FOR EACH COLUMN C **** ARRAY CLEN() GIVES THE NUMBER OF NON-ZERO COEFFICIENTS C **** IN EACH COLUMN C **** NOTE THAT THE DIAGONAL ELEMENTS OF L ARE ALLOCATED IN THE C **** DATA STRUCTURE BUT NOT USED BY THIS SOLVER. THIS IS BECAUSE C **** AN LL CHOLESKI SOLVER IS ALSO USED WHICH STORES THE DIAGONAL C **** ELEMENTS ALONG WITH THE COLUMNS RATHER THAN SEPARATELY C **** SOLVE LY=B NOPSS=0 IF ((SOPER.EQ.0).OR.(SOPER.EQ.1)) THEN DO 1 COLM=1,N IF (B(COLM).NE.0.0) THEN ISHIFT=CPTR(COLM)-COLM C$DIR NO_RECURRENCE DO 10 ROW=COLM+1,COLM+CLEN(COLM)-1 B(ROW)=B(ROW)-A(ISHIFT+ROW)*B(COLM) 10 CONTINUE NOPSS=NOPSS+(CLEN(COLM)-1)*2 END IF 1 CONTINUE ENDIF C **** SOLVE Y = D**-1 Y DO 2 ROW=1,N 2 B(ROW)=AD(ROW)*B(ROW) C **** SOLVE L(TRANSP)X=Y IF ((SOPER.EQ.0).OR.(SOPER.EQ.2)) THEN DO 3 ROW=N-1,1,-1 ISHIFT=CPTR(ROW)-ROW C$DIR NO_RECURRENCE DO 30 COLM=ROW+1,ROW+CLEN(ROW)-1 B(ROW)=B(ROW)-A(ISHIFT+COLM)*B(COLM) 30 CONTINUE NOPSS=NOPSS+2*(CLEN(ROW)-1) 3 CONTINUE ENDIF RETURN END SUBROUTINE VBLDS4(A,ALTH,AD,CPTR,CLEN,N,B,NOPSS,SOPER) INTEGER ALTH,N,NOPSS,SOPER DOUBLE PRECISION SUM, SUM1, SUM2, SUM3, SUM4 INTEGER LEFT, LAST, N0S, IS1, IS2, IS3, IS4, LASTR, ICT, KROW, C LASTC DOUBLE PRECISION A(ALTH),B(N),AD(N) INTEGER CPTR(N),CLEN(N),ROW,COLM C **** THIS LDL SOLVER ASSUMES THAT L IS UNIT LOWER TRIANGULAR C **** AND THE DIAGONAL MATRIX D IS STORED IN ARRAY AD() C **** IN INVERTED FORM (D**-1.) C **** THE COEFFICIENTS OF L ARE STORED BY COLUMNS C **** WITH ARRAY A() CONTAINING THE COEFFICIENTS C ***** ARRAY CPTR() CONTAINS THE STARTING LOCATION OF THE C **** COEFFICIENTS FOR EACH COLUMN C **** ARRAY CLEN() GIVES THE NUMBER OF NON-ZERO COEFFICIENTS C **** IN EACH COLUMN C **** NOTE THAT THE DIAGONAL ELEMENTS OF L ARE ALLOCATED IN THE C **** DATA STRUCTURE BUT NOT USED BY THIS SOLVER. THIS IS BECAUSE C **** AN LL CHOLESKI SOLVER IS ALSO USED WHICH STORES THE DIAGONAL C **** ELEMENTS ALONG WITH THE COLUMNS RATHER THAN SEPARATELY C **** SOLVE LY=B NOPSS=0 C **** LEFT IS THE NUMBER OF ROWS LEFT AT THE END OF THE MATRIX C **** IF B IS COMPUTED NROLL ELEMENTS AT A TIME C **** COLUMNS BEGINNING WITH LAST ARE COMPUTED IN A SERIAL LOOP C **** ELEMENTS 1 THRU LAST OF B() ARE COMPUTED BY COLUMN SWEEP C **** WITH LOOP UNROLLING LEVEL NROLL IF ((SOPER.EQ.0).OR.(SOPER.EQ.1)) THEN LEFT=MOD(N,4) LAST=N-LEFT-4 DO 1 ROW=1,LAST,4 N0S=0 IF (B(ROW).EQ.0.0) THEN IF (B(ROW+1).EQ.0.0) THEN IF (B(ROW+2).EQ.0.0) THEN IF (B(ROW+3).EQ.0.0) THEN N0S=4 ENDIF ENDIF ENDIF ENDIF IF (N0S.EQ.0) THEN IS1=CPTR(ROW)+4 IS2=CPTR(ROW+1)+3 IS3=CPTR(ROW+2)+2 IS4=CPTR(ROW+3)+1 B(ROW+1)=B(ROW+1)-B(ROW)*A(IS1-3) B(ROW+2)=B(ROW+2)-B(ROW)*A(IS1-2)-B(ROW+1)*A(IS2-2) B(ROW+3)=B(ROW+3)-B(ROW)*A(IS1-1)-B(ROW+1)*A(IS2-1) + -B(ROW+2)*A(IS3-1) NOPSS=NOPSS+12 LASTR=ROW+CLEN(ROW)-1 IF (LASTR.GE.ROW+4) THEN NOPSS=NOPSS+(LASTR-ROW-3)*8 ICT=0 CNORECUR DO 10 KROW=ROW+4,LASTR B(KROW)=B(KROW)-B(ROW)*A(IS1+ICT) + -B(ROW+1)*A(IS2+ICT) + -B(ROW+2)*A(IS3+ICT) + -B(ROW+3)*A(IS4+ICT) ICT=ICT+1 10 CONTINUE END IF END IF 1 CONTINUE DO 2 ROW=LAST+1,N-1 IF (B(ROW).NE.0.0) THEN IS1=CPTR(ROW)+1 LASTR=ROW+CLEN(ROW)-1 IF (LASTR.GE.ROW+1) THEN ICT=0 NOPSS=NOPSS+(LASTR-ROW)*2 DO 20 KROW=ROW+1,LASTR B(KROW)=B(KROW)-A(IS1+ICT)*B(ROW) ICT=ICT+1 20 CONTINUE END IF END IF 2 CONTINUE ENDIF C **** SOLVE Y = D**-1 Y DO 3 ROW=1,N 3 B(ROW)=AD(ROW)*B(ROW) NOPSS=NOPSS+N C **** SOLVE L(TRANSP)X=Y IF ((SOPER.EQ.0).OR.(SOPER.EQ.2)) THEN DO 4 ROW=N-1,LAST+1,-1 IS1=CPTR(ROW)+1 LASTC=ROW+CLEN(ROW)-1 ICT=0 NOPSS=NOPSS+(CLEN(ROW)-1)*2 SUM=0.0 DO 40 COLM=ROW+1,LASTC SUM=SUM+A(IS1+ICT)*B(COLM) 40 ICT=ICT+1 B(ROW)=B(ROW)-SUM 4 CONTINUE DO 5 ROW=LAST,1,-4 LASTC=ROW+CLEN(ROW)-1 IS4=CPTR(ROW)+1 IS3=CPTR(ROW-1)+2 IS2=CPTR(ROW-2)+3 IS1=CPTR(ROW-3)+4 ICT=0 SUM1=0.0 SUM2=0.0 SUM3=0.0 SUM4=0.0 IF (LASTC.GT.ROW) THEN ICT=0 NOPSS=NOPSS+8*(LASTC-ROW) CNORECUR DO 50 COLM=ROW+1,LASTC SUM4=SUM4+A(IS4+ICT)*B(COLM) SUM3=SUM3+A(IS3+ICT)*B(COLM) SUM2=SUM2+A(IS2+ICT)*B(COLM) SUM1=SUM1+A(IS1+ICT)*B(COLM) ICT=ICT+1 50 CONTINUE END IF B(ROW)=B(ROW)-SUM4 B(ROW-1)=B(ROW-1)-SUM3-A(IS3-1)*B(ROW) B(ROW-2)=B(ROW-2)-SUM2-A(IS2-1)*B(ROW)-A(IS2-2)*B(ROW-1) B(ROW-3)=B(ROW-3)-SUM1-A(IS1-1)*B(ROW)-A(IS1-2)*B(ROW-1)- + A(IS1-3)*B(ROW-2) NOPSS=NOPSS+16 5 CONTINUE ENDIF RETURN END SUBROUTINE VBLDS6(A,ALTH,AD,CPTR,CLEN,N,B,NOPSS,SOPER) INTEGER ALTH,N,NOPSS,SOPER DOUBLE PRECISION A(ALTH),B(N),AD(N) INTEGER CPTR(N),CLEN(N) * THE FOLLOWING ARE LOCALLY DECLARED VARIABLES INTEGER ROW,COLM, LEFT, LAST, LASTR, ICT, LASTC, C KROW, IS1, IS2, IS3, IS4, IS5, IS6 DOUBLE PRECISION SUM1, SUM2, SUM3, SUM4, SUM5 C **** THIS LDL SOLVER ASSUMES THAT L IS UNIT LOWER TRIANGULAR C **** AND THE DIAGONAL MATRIX D IS STORED IN ARRAY AD() C **** IN INVERTED FORM (D**-1.) C **** THE COEFFICIENTS OF L ARE STORED BY COLUMNS C **** WITH ARRAY A() CONTAINING THE COEFFICIENTS C ***** ARRAY CPTR() CONTAINS THE STARTING LOCATION OF THE C **** COEFFICIENTS FOR EACH COLUMN C **** ARRAY CLEN() GIVES THE NUMBER OF NON-ZERO COEFFICIENTS C **** IN EACH COLUMN C **** NOTE THAT THE DIAGONAL ELEMENTS OF L ARE ALLOCATED IN THE C **** DATA STRUCTURE BUT NOT USED BY THIS SOLVER. THIS IS BECAUSE C **** AN LL CHOLESKI SOLVER IS ALSO USED WHICH STORES THE DIAGONAL C **** ELEMENTS ALONG WITH THE COLUMNS RATHER THAN SEPARATELY C **** SOLVE LY=B NOPSS=0 C **** LEFT IS THE NUMBER OF ROWS LEFT AT THE END OF THE MATRIX C **** IF B IS COMPUTED NROLL ELEMENTS AT A TIME C **** COLUMNS BEGINNING WITH LAST ARE COMPUTED IN A SERIAL LOOP C **** ELENETS 1 THRU LAST OF B() ARE COMPUTED BY COLUMN SWEEP C **** WITH LOOP UNROLLING LEVEL NROLL C B(COLM)=1.0/30. C WRITE(6,6001) COLM, AD(COLM) C ISHIFT=CPTR(COLM)-COLM C DO 610 ROW=COLM+1,COLM+CLEN(COLM)-1 C IF (A(ISHIFT+ROW).NE.0.0) WRITE(6,6002) ROW,ISHIFT+ROW, C + A(ISHIFT+ROW) C610 CONTINUE C61 CONTINUE C6001 FORMAT(1X,' D( ',I5,')=',G14.6) C6002 FORMAT(5X,' ROW=',I5,' INDEX=',I7,' COEF=',G15.7) C6003 FORMAT(1X,' COLM=',I4,' LENGTH =',I5) LEFT=MOD(N,6) LAST=N-LEFT-6 IF ((SOPER.EQ.0).OR.(SOPER.EQ.1)) THEN DO 1 ROW=1,LAST,6 IS1=CPTR(ROW)+6 IS2=CPTR(ROW+1)+5 IS3=CPTR(ROW+2)+4 IS4=CPTR(ROW+3)+3 IS5=CPTR(ROW+4)+2 IS6=CPTR(ROW+5)+1 B(ROW+1)=B(ROW+1)-B(ROW)*A(IS1-5) B(ROW+2)=B(ROW+2)-B(ROW)*A(IS1-4)-B(ROW+1)*A(IS2-4) B(ROW+3)=B(ROW+3)-B(ROW)*A(IS1-3)-B(ROW+1)*A(IS2-3) + -B(ROW+2)*A(IS3-3) B(ROW+4)=B(ROW+4)-B(ROW)*A(IS1-2)-B(ROW+1)*A(IS2-2) + -B(ROW+2)*A(IS3-2)-B(ROW+3)*A(IS4-2) B(ROW+5)=B(ROW+5)-B(ROW)*A(IS1-1)-B(ROW+1)*A(IS2-1) + -B(ROW+2)*A(IS3-1)-B(ROW+3)*A(IS4-1) + -B(ROW+4)*A(IS5-1) NOPSS=NOPSS+30 LASTR=ROW+CLEN(ROW)-1 IF (LASTR.GE.ROW+6) THEN NOPSS=NOPSS+(LASTR-ROW-3)*12 ICT=0 CNORECUR DO 10 KROW=ROW+6,LASTR B(KROW)=B(KROW)-B(ROW)*A(IS1+ICT) + -B(ROW+1)*A(IS2+ICT) + -B(ROW+2)*A(IS3+ICT) + -B(ROW+3)*A(IS4+ICT) + -B(ROW+4)*A(IS5+ICT) + -B(ROW+5)*A(IS6+ICT) ICT=ICT+1 10 CONTINUE END IF 1 CONTINUE DO 2 ROW=LAST+1,N-1 IS1=CPTR(ROW)+1 LASTR=ROW+CLEN(ROW)-1 IF (LASTR.GE.ROW+1) THEN ICT=0 NOPSS=NOPSS+(LASTR-ROW)*2 DO 20 KROW=ROW+1,LASTR B(KROW)=B(KROW)-A(IS1+ICT)*B(ROW) ICT=ICT+1 20 CONTINUE END IF 2 CONTINUE ENDIF C WRITE(6,*) ' B() AFTER FORWARD SOLVE' C DO 166 COLM=1,N C166 WRITE(6,6003) COLM,B(COLM) C6003 FORMAT(1X,'B(',I5,')=',G15.7) C **** SOLVE Y = D**-1 Y DO 3 ROW=1,N B(ROW)=AD(ROW)*B(ROW) 3 CONTINUE NOPSS=NOPSS+N C **** SOLVE L(TRANSP)X=Y IF ((SOPER.EQ.0).OR.(SOPER.EQ.2)) THEN DO 4 ROW=N-1,LAST+1,-1 IS1=CPTR(ROW)+1 LASTC=ROW+CLEN(ROW)-1 ICT=0 NOPSS=NOPSS+(CLEN(ROW)-1)*2 CNORECUR DO 40 COLM=ROW+1,LASTC B(ROW)=B(ROW)-A(IS1+ICT)*B(COLM) ICT=ICT+1 40 CONTINUE 4 CONTINUE DO 5 ROW=LAST,1,-6 LASTC=ROW+CLEN(ROW)-1 IS6=CPTR(ROW)+1 IS5=CPTR(ROW-1)+2 IS4=CPTR(ROW-2)+3 IS3=CPTR(ROW-3)+4 IS2=CPTR(ROW-4)+5 IS1=CPTR(ROW-5)+6 ICT=0 IF (LASTC.GT.ROW) THEN ICT=0 NOPSS=NOPSS+12*(LASTC-ROW) CNORECUR DO 50 COLM=ROW+1,LASTC B(ROW)=B(ROW)-A(IS6+ICT)*B(COLM) B(ROW-1)=B(ROW-1)-A(IS5+ICT)*B(COLM) B(ROW-2)=B(ROW-2)-A(IS4+ICT)*B(COLM) B(ROW-3)=B(ROW-3)-A(IS3+ICT)*B(COLM) B(ROW-4)=B(ROW-4)-A(IS2+ICT)*B(COLM) B(ROW-5)=B(ROW-5)-A(IS1+ICT)*B(COLM) ICT=ICT+1 50 CONTINUE END IF SUM5=A(IS5-1)*B(ROW) B(ROW-1)=B(ROW-1)-SUM5 SUM4=A(IS4-1)*B(ROW)+A(IS4-2)*B(ROW-1) B(ROW-2)=B(ROW-2)-SUM4 SUM3=A(IS3-1)*B(ROW)+A(IS3-2)*B(ROW-1)+A(IS3-3)*B(ROW-2) B(ROW-3)=B(ROW-3)-SUM3 SUM2=A(IS2-1)*B(ROW)+A(IS2-2)*B(ROW-1)+A(IS2-3)*B(ROW-2)+ + A(IS2-4)*B(ROW-3) B(ROW-4)=B(ROW-4)-SUM2 SUM1=A(IS1-1)*B(ROW)+A(IS1-2)*B(ROW-1)+A(IS1-3)*B(ROW-2)+ + A(IS1-4)*B(ROW-3)+A(IS1-5)*B(ROW-4) B(ROW-5)=B(ROW-5)-SUM1 NOPSS=NOPSS+30 5 CONTINUE ENDIF C WRITE(6,*) ' B() AFTER BACK SOLVE' C DO 366 COLM=1,N C366 WRITE(6,6003) COLM,B(COLM) RETURN END SUBROUTINE VBLLS1(ABD,ALTH,ROWPTR,ROWLEN,N,B,NOPSS) INTEGER ALTH,N,I,J,T1,T2,NOPSS DOUBLE PRECISION + ABD(ALTH),B(N) INTEGER ROWPTR(N),ROWLEN(N) C SOLVE LY=B NOPSS=0 DO 10 I=1,N B(I)=B(I)/ABD(ROWPTR(I)) C CALL SAXPY(ROWLEN(I)-1,-B(I),ABD(ROWPTR(I)+1),1,B(I+1),1) T1=ROWPTR(I) CNORECUR DO 20 J=I+1,ROWLEN(I)+I-1 T1=T1+1 B(J)=B(J)-ABD(T1)*B(I) 20 CONTINUE NOPSS=NOPSS+(ROWLEN(I)-1)*2 10 CONTINUE C SOLVE L(TRANSP)X=Y B(N)=B(N)/ABD(ROWPTR(N)) DO 30 I=N-1,1,-1 C T=SDOT(ROWLEN(I)-1,ABD(ROWPTR(I)+1),1,B(I+1),1) C B(I)=(B(I)-T)/ABD(ROWPTR(I)) T1=0 T2=ROWPTR(I) CNORECUR DO 40 J=1,ROWLEN(I)-1 T1=T1+1 B(I)=B(I)-ABD(T2+J)*B(I+T1) 40 CONTINUE B(I)=B(I)/ABD(ROWPTR(I)) NOPSS=NOPSS+2*(ROWLEN(I)-1) 30 CONTINUE RETURN END SUBROUTINE VBLLS4(ABD,ALTH,ROWPTR,ROWLEN,N,B,NOPSS) INTEGER ALTH,N,I,J,T1,T2,NOPSS INTEGER IST1,IST2,IST3,IST4,T3,T4,T5, LEFT, K DOUBLE PRECISION ABD(ALTH),B(N) INTEGER ROWPTR(N),ROWLEN(N) C ***** REVISED JAN 89 BY E.L. POOLE THIS VERSION ASSUMES THAT THE C ***** DIAGONAL ELEMENTS OF L ARE ACTUALLY THE RECIPROCALS OF L(I,I) C ***** THIS SHOULD SAVE TIME SINCE MULTIPLICATIONS ARE FASTER THAN C ***** DIVIDES ON THE CRAY. C SOLVE LY=B NOPSS=0 I=1 10 CONTINUE IST1=ROWPTR(I) IST2=ROWPTR(I+1) IST3=ROWPTR(I+2) IST4=ROWPTR(I+3) B(I)=B(I)*ABD(IST1) B(I+1)=(B(I+1)-ABD(IST1+1)*B(I))*ABD(IST2) B(I+2)=(B(I+2)-ABD(IST1+2)*B(I)-ABD(IST2+1)*B(I+1)) + *ABD(IST3) B(I+3)=(B(I+3)-ABD(IST1+3)*B(I)-ABD(IST2+2)*B(I+1)- + ABD(IST3+1)*B(I+2))*ABD(IST4) NOPSS=NOPSS+16 T1=IST1+4 T2=IST2+3 T3=IST3+2 T4=IST4+1 CNORECUR DO 20 J=I+4,ROWLEN(I)+I-1 B(J)=B(J)-ABD(T1)*B(I)-ABD(T2)*B(I+1)-ABD(T3)*B(I+2) + -ABD(T4)*B(I+3) T1=T1+1 T2=T2+1 T3=T3+1 T4=T4+1 20 CONTINUE NOPSS=NOPSS+8*(ROWLEN(I)-4) I=I+4 IF (I.LE.N-5) GOTO 10 GOTO (30,40,50,60),(N-I) 60 CONTINUE I=N-4 IST1=ROWPTR(I) B(I)=B(I)*ABD(IST1) B(I+1)=B(I+1)-ABD(IST1+1)*B(I) B(I+2)=B(I+2)-ABD(IST1+2)*B(I) B(I+3)=B(I+3)-ABD(IST1+3)*B(I) B(N)=B(N)-ABD(IST1+4)*B(I) NOPSS=NOPSS+9 50 CONTINUE I=N-3 IST1=ROWPTR(I) B(I)=B(I)*ABD(IST1) B(I+1)=B(I+1)-ABD(IST1+1)*B(I) B(I+2)=B(I+2)-ABD(IST1+2)*B(I) B(N)=B(N)-ABD(IST1+3)*B(I) NOPSS=NOPSS+7 40 CONTINUE I=N-2 IST1=ROWPTR(I) B(I)=B(I)*ABD(IST1) B(I+1)=B(I+1)-ABD(IST1+1)*B(I) B(N)=B(N)-ABD(IST1+2)*B(I) NOPSS=NOPSS+5 30 CONTINUE I=N-1 IST1=ROWPTR(I) B(I)=B(I)*ABD(IST1) B(N)=(B(N)-ABD(IST1+1)*B(I))*ABD(ROWPTR(N)) NOPSS=NOPSS+4 C SOLVE L(TRANSP)X=Y LEFT=MOD(N-2,4) B(N)=B(N)*ABD(ROWPTR(N)) IST1=ROWPTR(N-1) B(N-1)=(B(N-1)-ABD(IST1+1)*B(N))*ABD(IST1) K=N-2 NOPSS=NOPSS+4 IF (LEFT.EQ.1) THEN IST1=ROWPTR(N-2) B(N-2)=(B(N-2)-ABD(IST1+1)*B(N-1)-ABD(IST1+2)*B(N)) + *ABD(IST1) K=K-1 NOPSS=NOPSS+5 ELSEIF (LEFT.EQ.2) THEN IST1=ROWPTR(N-2) B(N-2)=(B(N-2)-ABD(IST1+1)*B(N-1)-ABD(IST1+2)*B(N)) + *ABD(IST1) IST1=ROWPTR(N-3) B(N-3)=(B(N-3)-ABD(IST1+1)*B(N-2)-ABD(IST1+2)*B(N-1) + -ABD(IST1+3)*B(N))*ABD(IST1) K=K-2 NOPSS=NOPSS+12 ELSEIF (LEFT.EQ.3) THEN IST1=ROWPTR(N-2) B(N-2)=(B(N-2)-ABD(IST1+1)*B(N-1)-ABD(IST1+2)*B(N)) + *ABD(IST1) IST1=ROWPTR(N-3) B(N-3)=(B(N-3)-ABD(IST1+1)*B(N-2)-ABD(IST1+2)*B(N-1) + -ABD(IST1+3)*B(N))*ABD(IST1) IST1=ROWPTR(N-4) B(N-4)=(B(N-4)-ABD(IST1+1)*B(N-3)-ABD(IST1+2)*B(N-2) + -ABD(IST1+3)*B(N-1)-ABD(IST1+4)*B(N))*ABD(IST1) NOPSS=NOPSS+21 K=K-3 END IF 70 CONTINUE IST1=ROWPTR(K) IST2=ROWPTR(K-1) IST3=ROWPTR(K-2) IST4=ROWPTR(K-3) T1=1 T2=IST1+1 T3=IST2+2 T4=IST3+3 T5=IST4+4 CNORECUR DO 80 J=2,ROWLEN(K) B(K)=B(K)-ABD(T2)*B(K+T1) B(K-1)=B(K-1)-ABD(T3)*B(K+T1) B(K-2)=B(K-2)-ABD(T4)*B(K+T1) B(K-3)=B(K-3)-ABD(T5)*B(K+T1) T1=T1+1 T2=T2+1 T3=T3+1 T4=T4+1 T5=T5+1 80 CONTINUE NOPSS=NOPSS+8*(ROWLEN(K)-1) B(K)=B(K)*ABD(IST1) B(K-1)=(B(K-1)-ABD(IST2+1)*B(K))*ABD(IST2) B(K-2)=(B(K-2)-ABD(IST3+1)*B(K-1)-ABD(IST3+2)*B(K)) + *ABD(IST3) B(K-3)=(B(K-3)-ABD(IST4+1)*B(K-2)-ABD(IST4+2)*B(K-1) + -ABD(IST4+3)*B(K))*ABD(IST4) K=K-4 IF (K.GT.0) GOTO 70 RETURN END C$FORTRAN VCROUT *********************************************************************** * LANZ SOFTWARE PACKAGE * * FILENAME: VCROUT.MSC * * AUTHOR: MARK JONES * * PURPOSE: PERFORMS MATRIX OPERATIONS AND SOME ERROR CALCS * * CALLS THE BLAS FOR MUCH OF THE WORK * *********************************************************************** * A COLLECTION OF MAINLY VECTOR ROUTINES * A NON-VECTOR FUNCTION FOR EIGENVALUE TRANSFORM DOUBLE PRECISION FUNCTION EIGTRA(EIG,SIGMA,PROB) * THE EIGENVALUE DOUBLE PRECISION EIG * THE SIGMA BEING SEARCHED AROUND DOUBLE PRECISION SIGMA * VIBRATION (0) OR BUCKLING (1) INTEGER PROB IF (PROB.EQ.0) THEN EIGTRA = SIGMA+(1.0D0/EIG) ELSE IF (PROB.EQ.1) THEN EIGTRA = (((SIGMA*EIG)/(EIG-1.0D0))) ELSE EIGTRA = -1.0D0/EIG ENDIF RETURN END * A NON-VECTOR FUNCTION FOR REVERSING THE TRANSFORM DOUBLE PRECISION FUNCTION REVEIG(LAMBDA,SIGMA,PROB) * THE EIGENVALUE DOUBLE PRECISION LAMBDA * THE SIGMA BEING SEARCHED AROUND DOUBLE PRECISION SIGMA * VIBRATION (0) OR BUCKLING (1) INTEGER PROB IF (PROB.EQ.0) THEN REVEIG = 1.0D0/(LAMBDA-SIGMA) ELSE IF (PROB.EQ.1) THEN REVEIG = 1.0D0/(1-(SIGMA/LAMBDA)) ELSE REVEIG = -1.0D0/LAMBDA ENDIF RETURN END * A NON-VECTOR ROUTINE FOR RELATIVE ERROR DOUBLE PRECISION FUNCTION RELERR(EIG,ERROR,SIGMA,PROB) * THE EIGENVALUE DOUBLE PRECISION EIG * THE ERROR DOUBLE PRECISION ERROR * THE SIGMA BEING SEARCHED AROUND DOUBLE PRECISION SIGMA * VIBRATION (0) OR BUCKLING (1) INTEGER PROB * INTERNAL VARIABLES * A TEMPORARY VALUE DOUBLE PRECISION TVAL * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION ABSERR, EIGTRA EXTERNAL ABSERR, EIGTRA TVAL = ABS(ABSERR(EIG,ERROR,SIGMA,PROB)/ C EIGTRA(EIG,SIGMA,PROB)) IF (PROB.EQ.0) THEN RELERR = TVAL ELSE RELERR = MAX(TVAL,ERROR) ENDIF RETURN END * A NON-VECTOR ROUTINE FOR RELATIVE ERROR DOUBLE PRECISION FUNCTION MRELER(EIG,ERROR,SIGMA,PROB) * THE EIGENVALUE DOUBLE PRECISION EIG * THE ERROR DOUBLE PRECISION ERROR * THE SIGMA BEING SEARCHED AROUND DOUBLE PRECISION SIGMA * VIBRATION (0) OR BUCKLING (1) INTEGER PROB * INTERNAL VARIABLES * TEMPORARY VARIABLES DOUBLE PRECISION T, TERROR * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION EIGTRA EXTERNAL EIGTRA TERROR = ABS(ERROR) IF ((PROB.EQ.0).OR.(PROB.EQ.2)) THEN IF (EIG.GT.0.0D0) THEN TERROR = -TERROR ENDIF MRELER = ABS(((1.0D0/(EIG+TERROR))-(1.0D0/EIG))/ C (EIGTRA(EIG,SIGMA,PROB))) ELSE T = EIGTRA(EIG,SIGMA,PROB) IF (EIG-1.0D0.GT.0.0D0) THEN TERROR = -TERROR ENDIF MRELER = ABS((EIGTRA(EIG+TERROR,SIGMA,PROB)-T)/T) ENDIF RETURN END * A NON-VECTOR ROUTINE FOR ABSOLUTE ERROR DOUBLE PRECISION FUNCTION ABSERR(EIG,ERROR,SIGMA,PROB) * THE EIGENVALUE DOUBLE PRECISION EIG * THE ERROR DOUBLE PRECISION ERROR * THE SIGMA BEING SEARCHED AROUND DOUBLE PRECISION SIGMA * VIBRATION (0) OR BUCKLING (1) INTEGER PROB * INTERNAL VARIABLES * A TEMPORARY VARIABLE DOUBLE PRECISION T, TERROR * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION EIGTRA EXTERNAL EIGTRA IF (PROB.EQ.0) THEN ABSERR = (ERROR/(EIG*EIG)) ELSE IF (PROB.EQ.2) THEN TERROR = ABS(ERROR) T = EIGTRA(EIG,SIGMA,PROB) IF (EIG.GT.0.0D0) THEN TERROR = -TERROR ENDIF ABSERR = ABS(EIGTRA(EIG+TERROR,SIGMA,PROB)-T) ELSE TERROR = ABS(ERROR) T = EIGTRA(EIG,SIGMA,PROB) IF (EIG-1.0D0.GT.0.0D0) THEN TERROR = -TERROR ENDIF ABSERR = ABS(EIGTRA(EIG+TERROR,SIGMA,PROB)-T) ENDIF RETURN END * A ROUTINE TO PRINT A VECTOR SUBROUTINE PRVEC(SIZE,INVEC) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE VECTOR DOUBLE PRECISION INVEC(SIZE) * INTERNAL VARIABLES * COUNT VARIABLE INTEGER I DO 10 I = 1, SIZE PRINT *, 'VEC(',I,')=',INVEC(I) 10 CONTINUE RETURN END * A ROUTINE TO FILL A VECTOR WITH RANDOM NUMBERS * UNFORTUNATELY WE DON'T DO RANDOM NUMBERS HERE * WE SORT OF USE INVAL TO OVERCOME THIS SUBROUTINE RNDVEC(SIZE,INVEC,INVAL) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE TARGET VECTOR DOUBLE PRECISION INVEC(SIZE) * A PSEUDO-SEED INTEGER INVAL INTEGER I, TINVAL TINVAL = MOD((INVAL*SIZE)/10,SIZE) IF (INVAL.EQ.0) THEN DO 10 I = 1, SIZE INVEC(I) = MOD(I+TINVAL,SIZE)+1 10 CONTINUE ELSE DO 20 I = 1, SIZE INVEC(I) = MOD(I+TINVAL,SIZE)+1 20 CONTINUE DO 30 I = 1, SIZE, INVAL INVEC(I) = -INVEC(I) 30 CONTINUE ENDIF RETURN END * A ROUTINE TO FILL A VECTOR WITH A SCALAR SUBROUTINE FLLVEC(SIZE,INVEC,VAL) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE TARGET VECTOR DOUBLE PRECISION INVEC(SIZE) * THE SCALAR TO FILL WITH DOUBLE PRECISION VAL * INTERNAL VARIABLES * COUNT VARIABLE INTEGER I DO 10 I = 1, SIZE INVEC(I) = VAL 10 CONTINUE RETURN END * A ROUTINE TO COMPUTE THE INNER PRODUCT DOUBLE PRECISION FUNCTION SINPRD(SIZE,VEC1,VEC2) * THE LENGTH OF THE VECTORS INTEGER SIZE * THE MULTIPLYING VECTORS DOUBLE PRECISION VEC1(SIZE), VEC2(SIZE) * INTERNAL VARIABLE * DOUBLE PRECISION FUNCTION DOUBLE PRECISION DDOT EXTERNAL DDOT SINPRD = DDOT(SIZE,VEC1,1,VEC2,1) RETURN END * A ROUTINE TO DIVIDE A VECTOR BY A SCALAR SUBROUTINE VECDSC(SIZE,NEWVEC,OLDVEC,SCALAR) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE RECEIVING VECTOR DOUBLE PRECISION NEWVEC(SIZE) * THE OLD VECTOR DOUBLE PRECISION OLDVEC(SIZE) * THE MULTIPLYING SCALAR DOUBLE PRECISION SCALAR * INTERNAL VARIABLES * A TEMPORARY VARIABLE DOUBLE PRECISION DIVVAL EXTERNAL VECXSC IF (SCALAR.EQ.0.0D0) THEN PRINT *,'ERROR: DIVIDE BY ZERO IN VECDSCA' PRINT *,'REMEDY: CHECK TO MAKE SURE YOUR DATASETS ARE OKAY' PRINT *,'REMEDY: IF SO, CONTACT TESTBED ADMINISTRATOR' STOP ENDIF DIVVAL = 1.0D0 / SCALAR CALL VECXSC(SIZE,NEWVEC,OLDVEC,DIVVAL) RETURN END * A ROUTINE TO DIVIDE TWO VECTORS BY A SCALAR SUBROUTINE VC2DSC(SIZE,NEWVC1,OLDVC1,NEWVC2,OLDVC2,SCALAR) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE RECEIVING VECTOR DOUBLE PRECISION NEWVC1(SIZE) * THE OLD VECTOR DOUBLE PRECISION OLDVC1(SIZE) * THE RECEIVING VECTOR DOUBLE PRECISION NEWVC2(SIZE) * THE OLD VECTOR DOUBLE PRECISION OLDVC2(SIZE) * THE MULTIPLYING SCALAR DOUBLE PRECISION SCALAR * INTERNAL VARIABLES * A TEMPORARY VARIABLE DOUBLE PRECISION DIVVAL * A COUNT VARIABLE INTEGER I IF (SCALAR.EQ.0.0D0) THEN PRINT *,'ERROR: DIVIDE BY ZERO IN VECDSCA' PRINT *,'REMEDY: CHECK TO MAKE SURE YOUR DATASETS ARE OKAY' PRINT *,'REMEDY: IF SO, CONTACT TESTBED ADMINISTRATOR' STOP ENDIF DIVVAL = 1.0D0 / SCALAR DO 10 I = 1, SIZE NEWVC1(I) = OLDVC1(I)*DIVVAL NEWVC2(I) = OLDVC2(I)*DIVVAL 10 CONTINUE RETURN END * A ROUTINE TO MULTIPLY A VECTOR TIMES A SCALAR SUBROUTINE VECXSC(SIZE,NEWVEC,OLDVEC,SCALAR) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE RECEIVING VECTOR DOUBLE PRECISION NEWVEC(SIZE) * THE OLD VECTOR DOUBLE PRECISION OLDVEC(SIZE) * THE MULTIPLYING SCALAR DOUBLE PRECISION SCALAR EXTERNAL CPYVEC EXTERNAL DSCAL CALL CPYVEC(SIZE,NEWVEC,OLDVEC) CALL DSCAL(SIZE,SCALAR,NEWVEC,1) RETURN END * A ROUTINE TO ADD ONE VECTOR TO ANOTHER SUBROUTINE VECADD(SIZE,NEWVEC,VEC1,VEC2) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE RECEIVING VECTOR DOUBLE PRECISION NEWVEC(SIZE) * THE OLD VECTORS DOUBLE PRECISION VEC2(SIZE),VEC1(SIZE) EXTERNAL CPYVEC EXTERNAL DAXPY CALL CPYVEC(SIZE,NEWVEC,VEC1) CALL DAXPY(SIZE,1.0D0,VEC2,1,NEWVEC,1) RETURN END * A ROUTINE TO SUBTRACT ONE VECTOR FROM ANOTHER SUBROUTINE VECSUB(SIZE,NEWVEC,VEC1,VEC2) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE RECEIVING VECTOR DOUBLE PRECISION NEWVEC(SIZE) * THE OLD VECTORS DOUBLE PRECISION VEC2(SIZE),VEC1(SIZE) EXTERNAL CPYVEC EXTERNAL DAXPY CALL CPYVEC(SIZE,NEWVEC,VEC1) CALL DAXPY(SIZE,-1.0D0,VEC2,1,NEWVEC,1) RETURN END * A ROUTINE TO DO THE SAXPY OPERATION SUBROUTINE VECSAX(SIZE,YVEC,XVEC,AVAL) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE RECEIVING VECTOR DOUBLE PRECISION YVEC(SIZE) * THE OLD VECTOR DOUBLE PRECISION XVEC(SIZE) * THE SCALAR VALUE DOUBLE PRECISION AVAL EXTERNAL DAXPY CALL DAXPY(SIZE,AVAL,XVEC,1,YVEC,1) RETURN END * A ROUTINE TO COPY ONE VECTOR TO ANOTHER SUBROUTINE CPYVEC(SIZE,NEWVEC,OLDVEC) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE RECEIVING VECTOR DOUBLE PRECISION NEWVEC(SIZE) * THE OLD VECTOR DOUBLE PRECISION OLDVEC(SIZE) EXTERNAL DCOPY CALL DCOPY(SIZE,OLDVEC,1,NEWVEC,1) RETURN END * A ROUTINE TO ORTHOGONALIZE TWO VECTORS DOUBLE PRECISION FUNCTION SORTHO(SIZE,NEWVEC,OLDVEC,MVEC,TRVEC, C EPS,ORTH) * THE LENGTH OF THE VECTOR INTEGER SIZE * THE MODIFIED VECTOR DOUBLE PRECISION NEWVEC(SIZE) * THE MATRIX TIMES ONE OF THE VECTORS DOUBLE PRECISION OLDVEC(SIZE) * THE VECTOR TO MULTIPLY BY OLDVEC DOUBLE PRECISION MVEC(SIZE) * THE VECTOR ITSELF DOUBLE PRECISION TRVEC(SIZE) * THE VALUE TO COMPARE AGAINST ORTHOGONALITY * (IF NEGATIVE THEN DON'T CHECK) DOUBLE PRECISION EPS * DID WE ORTHOGONALIZE LOGICAL ORTH * INTERNAL VARIABLES * A TEMPORARY VARIABLE DOUBLE PRECISION TVAL * DOUBLE PRECISION FUNCTIONS DOUBLE PRECISION SINPRD EXTERNAL SINPRD, VECSAX TVAL = SINPRD(SIZE,MVEC,OLDVEC) SORTHO = TVAL IF ((ABS(TVAL).LT.EPS).AND.(.NOT. ORTH)) RETURN ORTH = .TRUE. CALL VECSAX(SIZE,NEWVEC,TRVEC,-TVAL) RETURN END * A FUNCTION THAT RETURNS THE INDEX OF THE LARGEST ABSOLUTE VALUE * IN A VECTOR AND PUTS THE VALUE INTO MAXVAL INTEGER FUNCTION IGETMX(START,FINISH,INC,INVEC,MAXVAL) * STARTING INDEX INTEGER START * LAST INDEX INTEGER FINISH * INCREMENT INTEGER INC * VECTOR TO SEARCH DOUBLE PRECISION INVEC(*) * THE MAXIMUM VALUE DOUBLE PRECISION MAXVAL * INTERNAL VARIABLES INTEGER IDAMAX INTEGER ITEMP INTEGER ILEN EXTERNAL IDAMAX IF (FINISH-START.GE.0) THEN ILEN = FINISH-START ILEN = ((ILEN - MOD(ILEN,INC))/INC) + 1 ITEMP = IDAMAX(ILEN,INVEC(START),INC) ITEMP = (ITEMP-1)*INC + START MAXVAL = ABS(INVEC(ITEMP)) IGETMX = ITEMP ENDIF RETURN END