* F06HBF Example Program Text * Mark 20 Revised. NAG Copyright 2001. * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) * .. Local Scalars .. COMPLEX*16 CZERO DOUBLE PRECISION EIGHT, ELEVEN, EPS, FIVE, FLMAX, FLMIN, FOUR, + NINE, NINTEN, ONE, RTELEV, RTFIV, RTNNTN, RTSEV, + RTSIX, RTTHR, RTTHTY, RTTWO, SEVEN, SIX, TEN, + THIRTY, THREE, THRTEN, TOL, TWELVE, TWO, ZERO INTEGER DUM, I, N, NCCORR, NCCORX, NCCORY, NCENTX, + NCENTY, NCREST, NININT, NRCORR, NRCORX, NRENTX, + NRREST * .. Local Arrays .. COMPLEX*16 ALPHA(15), BETA(15), CCORR(15,6), CCORX(15,6), + CCORY(15,6), CENTX(15,6), CENTY(15,6), + CORRS(15,6), CREST(15,6) DOUBLE PRECISION CORRC(15,6), RCORR(15,6), RCORX(15,6), + RENTX(15,6), RREST(15,6) INTEGER ININT(15,6) CHARACTER DIRECT(15), PIVOT(15) * .. External Functions .. DOUBLE PRECISION X02AJF, X02AMF EXTERNAL X02AJF, X02AMF * .. External Subroutines .. EXTERNAL CHECK1, CHECK2, CHECK3, CHECK4, CPYRWC, CPYRWR, + INIT * .. Intrinsic Functions .. INTRINSIC DCMPLX, SQRT * .. Executable Statements .. WRITE (NOUT,99999) ZERO = 0 CZERO = DCMPLX(ZERO,ZERO) ONE = 1 TWO = 2 THREE = 3 FOUR = 4 FIVE = 5 SIX = 6 SEVEN = 7 EIGHT = 8 NINE = 9 TEN = 10 ELEVEN = 11 TWELVE = 12 THRTEN = 13 NINTEN = 19 THIRTY = 30 RTTWO = SQRT(TWO) RTTHR = SQRT(THREE) RTFIV = SQRT(FIVE) RTSIX = SQRT(SIX) RTSEV = SQRT(SEVEN) RTELEV = SQRT(ELEVEN) RTNNTN = SQRT(NINTEN) RTTHTY = SQRT(THIRTY) FLMIN = X02AMF() FLMAX = ONE/FLMIN EPS = X02AJF() TOL = EPS**0.666666D+0 DUM = 0 * * Initialise data for (CLOAD) F06HBF tests. N = 4 NCENTX = 5 NCCORX = 5 NCENTY = 0 NCCORY = 0 NCREST = 1 NCCORR = 0 NININT = 2 DO 20 I = 1, NCCORX CENTX(1,I) = CZERO CCORX(1,I) = CZERO 20 CONTINUE CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTX,NCENTX,1,4) CALL CPYRWC(CCORX,NCCORX,1,2) CALL CPYRWC(CCORX,NCCORX,1,3) CALL CPYRWC(CCORX,NCCORX,1,4) CALL INIT(1,NININT,ININT,5,1,DUM,DUM,DUM,DUM) CREST(1,1) = CZERO * CALL INIT(2,NININT,ININT,5,1,DUM,DUM,DUM,DUM) CREST(2,1) = DCMPLX(-ONE,ONE) DO 40 I = 1, NCCORX, ININT(2,2) CCORX(2,I) = DCMPLX(-ONE,ONE) 40 CONTINUE * CALL INIT(3,NININT,ININT,3,2,DUM,DUM,DUM,DUM) CREST(3,1) = DCMPLX(-FLMIN,-FLMIN) DO 60 I = 1, NCCORX, ININT(3,2) CCORX(3,I) = DCMPLX(-FLMIN,-FLMIN) 60 CONTINUE * CALL INIT(4,NININT,ININT,2,3,DUM,DUM,DUM,DUM) CREST(4,1) = DCMPLX(FLMAX,FLMAX) DO 80 I = 1, NCCORX, ININT(4,2) CCORX(4,I) = DCMPLX(FLMAX,FLMAX) 80 CONTINUE * * Perform (CLOAD) F06HBF tests. CALL CHECK1('F06HBF',N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CSCOPY) F06KFF tests. N = 4 NRENTX = 5 NRCORX = 0 NCENTY = 5 NCCORY = 5 NCREST = 0 NCCORR = 0 NININT = 3 RENTX(1,1) = -ONE RENTX(1,2) = TWO RENTX(1,3) = -THREE RENTX(1,4) = FOUR RENTX(1,5) = -FIVE DO 100 I = 1, NCCORY CENTY(1,I) = CZERO CCORY(1,I) = CZERO 100 CONTINUE CALL CPYRWR(RENTX,NRENTX,1,2) CALL CPYRWR(RENTX,NRENTX,1,3) CALL CPYRWR(RENTX,NRENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,2) CALL CPYRWC(CENTY,NCENTY,1,3) CALL CPYRWC(CENTY,NCENTY,1,4) CALL CPYRWC(CCORY,NCCORY,1,2) CALL CPYRWC(CCORY,NCCORY,1,3) CALL CPYRWC(CCORY,NCCORY,1,4) CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) DO 120 I = 1, NCCORY CCORY(1,I) = RENTX(1,I) 120 CONTINUE * CALL INIT(2,NININT,ININT,5,-1,1,DUM,DUM,DUM) DO 140 I = 1, NCCORY CCORY(2,I) = RENTX(2,NCCORY+1-I) 140 CONTINUE * CALL INIT(3,NININT,ININT,3,2,-2,DUM,DUM,DUM) CCORY(3,1) = RENTX(3,5) CCORY(3,3) = RENTX(3,3) CCORY(3,5) = RENTX(3,1) * CALL INIT(4,NININT,ININT,2,-3,-4,DUM,DUM,DUM) CCORY(4,1) = RENTX(4,1) CCORY(4,5) = RENTX(4,4) * * Perform (CSCOPY) F06KFF tests. CALL CHECK2('F06KFF',N,NRENTX,RENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NRCORX,RCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (SCSSQ) F06KJF tests. N = 4 NCENTX = 5 NCCORX = 0 NCENTY = 0 NCCORY = 0 NRREST = 2 NRCORR = 2 NININT = 2 CENTX(1,1) = DCMPLX(ZERO,ONE/FIVE) CENTX(1,2) = DCMPLX(-TWO/FIVE,FOUR/FIVE) CENTX(1,3) = DCMPLX(THREE/FIVE,THREE/FIVE) CENTX(1,4) = DCMPLX(-FOUR/FIVE,TWO/FIVE) CENTX(1,5) = DCMPLX(ONE/FIVE,-ONE) CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTX,NCENTX,1,4) CALL INIT(1,NININT,ININT,5,1,DUM,DUM,DUM,DUM) RREST(1,1) = ZERO RREST(1,2) = ONE RCORR(1,1) = ONE RCORR(1,2) = 17/FIVE * CALL INIT(2,NININT,ININT,5,1,DUM,DUM,DUM,DUM) RREST(2,1) = FLMAX RREST(2,2) = ONE RCORR(2,1) = FLMAX RCORR(2,2) = ONE * CALL INIT(3,NININT,ININT,3,2,DUM,DUM,DUM,DUM) RREST(3,1) = FLMIN RREST(3,2) = ONE RCORR(3,1) = ONE RCORR(3,2) = NINE/FIVE * CALL INIT(4,NININT,ININT,2,3,DUM,DUM,DUM,DUM) RREST(4,1) = ONE RREST(4,2) = TWO RCORR(4,1) = ONE RCORR(4,2) = 71/(FIVE*FIVE) * * Perform (SCSSQ) F06KJF tests. CALL CHECK3('F06KJF',N,NCENTX,CENTX,NCENTY,CENTY,NRREST,RREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NRCORR,RCORR,TOL) * * Initialise data for (CROT) F06HPF tests N = 13 NCENTX = 5 NCCORX = 5 NCENTY = 5 NCCORY = 5 NCREST = 2 NCCORR = 0 NININT = 3 CENTX(1,1) = DCMPLX(ONE,TWO) CENTX(1,2) = DCMPLX(ONE,THREE) CENTX(1,3) = DCMPLX(-THREE,ONE) CENTX(1,4) = DCMPLX(TWO,FOUR) CENTX(1,5) = DCMPLX(ONE,ZERO) CENTY(1,1) = DCMPLX(ZERO,TWO) CENTY(1,2) = DCMPLX(-THREE,ONE) CENTY(1,3) = DCMPLX(TWO,-TWO) CENTY(1,4) = DCMPLX(FOUR,ONE) CENTY(1,5) = DCMPLX(-THREE,-THREE) CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(1,1) = DCMPLX(THREE/FIVE,FOUR/FIVE) CREST(1,2) = CZERO CCORX(1,1) = DCMPLX(-ONE,TWO) CCORX(1,2) = DCMPLX(-NINE/FIVE,THRTEN/FIVE) CCORX(1,3) = DCMPLX(-THRTEN/FIVE,-NINE/FIVE) CCORX(1,4) = DCMPLX(-TWO,FOUR) CCORX(1,5) = DCMPLX(THREE/FIVE,FOUR/FIVE) CCORY(1,1) = DCMPLX(EIGHT/FIVE,SIX/FIVE) CCORY(1,2) = DCMPLX(-ONE,THREE) CCORY(1,3) = DCMPLX(-TWO/FIVE,-14/FIVE) CCORY(1,4) = DCMPLX(16/FIVE,-THRTEN/FIVE) CCORY(1,5) = DCMPLX(-21/FIVE,THREE/FIVE) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTY,NCENTY,1,2) CALL INIT(2,NININT,ININT,5,-1,-1,DUM,DUM,DUM) CREST(2,1) = DCMPLX(FLMIN,FLMIN) CREST(2,2) = DCMPLX(-ONE/RTTWO,ONE/RTTWO) CCORX(2,1) = DCMPLX(-RTTWO,-RTTWO) CCORX(2,2) = DCMPLX(RTTWO,-TWO*RTTWO) CCORX(2,3) = DCMPLX(-FOUR*FLMIN,TWO*RTTWO) CCORX(2,4) = DCMPLX(-FIVE/RTTWO,THREE/RTTWO) CCORX(2,5) = DCMPLX(THREE*RTTWO,FLMIN) CCORY(2,1) = DCMPLX(-ONE/RTTWO,THREE/RTTWO) CCORY(2,2) = DCMPLX(-RTTWO,TWO*RTTWO) CCORY(2,3) = DCMPLX(-TWO*RTTWO,-RTTWO) CCORY(2,4) = DCMPLX(-RTTWO,THREE*RTTWO) CCORY(2,5) = DCMPLX(ONE/RTTWO,ONE/RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTY,NCENTY,1,3) CALL INIT(3,NININT,ININT,3,-1,2,DUM,DUM,DUM) CREST(3,1) = DCMPLX(ONE/RTTWO,ZERO) CREST(3,2) = DCMPLX(ZERO,-ONE/RTTWO) CCORX(3,1) = DCMPLX(-RTTWO,FIVE/RTTWO) CCORX(3,2) = DCMPLX(-ONE/RTTWO,ONE/RTTWO) CCORX(3,3) = DCMPLX(-ONE/RTTWO,ONE/RTTWO) CCORX(3,4) = CENTX(3,4) CCORX(3,5) = CENTX(3,5) CCORY(3,1) = DCMPLX(ONE/RTTWO,FIVE/RTTWO) CCORY(3,2) = CENTY(3,2) CCORY(3,3) = DCMPLX(FIVE/RTTWO,-THREE/RTTWO) CCORY(3,4) = CENTY(3,4) CCORY(3,5) = DCMPLX(-ONE/RTTWO,-FOUR/RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,4) CALL INIT(4,NININT,ININT,2,3,-4,DUM,DUM,DUM) CREST(4,1) = DCMPLX(ONE/FIVE,TWO/FIVE) CREST(4,2) = DCMPLX(FOUR/FIVE,-TWO/FIVE) CCORX(4,1) = DCMPLX(-21/FIVE,-TWO/FIVE) CCORX(4,2) = CENTX(4,2) CCORX(4,3) = CENTX(4,3) CCORX(4,4) = DCMPLX(-TWO/FIVE,16/FIVE) CCORX(4,5) = CENTX(4,5) CCORY(4,1) = DCMPLX(FOUR/FIVE,-18/FIVE) CCORY(4,2) = CENTY(4,2) CCORY(4,3) = CENTY(4,3) CCORY(4,4) = CENTY(4,4) CCORY(4,5) = DCMPLX(-NINE/FIVE,-SEVEN/FIVE) * CALL CPYRWC(CENTX,NCENTX,1,5) CENTX(5,1) = DCMPLX(ONE,FIVE) CALL CPYRWC(CENTY,NCENTY,1,5) CALL INIT(5,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(5,1) = DCMPLX(ONE/RTTWO,ZERO) CREST(5,2) = DCMPLX(ONE/TWO,-ONE/TWO) CCORX(5,1) = DCMPLX(ONE+ONE/RTTWO,ONE+FIVE/RTTWO) CCORX(5,2) = DCMPLX(-ONE+ONE/RTTWO,TWO+THREE/RTTWO) CCORX(5,3) = DCMPLX(-THREE/RTTWO,-TWO+ONE/RTTWO) CCORX(5,4) = DCMPLX(FIVE/TWO+RTTWO,TWO*RTTWO-THREE/TWO) CCORX(5,5) = DCMPLX(ONE/RTTWO-THREE,ZERO) CCORY(5,1) = DCMPLX(TWO,RTTWO-THREE) CCORY(5,2) = DCMPLX(ONE-THREE/RTTWO,-TWO+ONE/RTTWO) CCORY(5,3) = DCMPLX(TWO+RTTWO,ONE-RTTWO) CCORY(5,4) = DCMPLX(ONE+TWO*RTTWO,ONE/RTTWO-THREE) CCORY(5,5) = DCMPLX(-ONE/TWO-THREE/RTTWO,-ONE/TWO-THREE/RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,6) CALL CPYRWC(CENTY,NCENTY,1,6) CALL INIT(6,NININT,ININT,3,1,-1,DUM,DUM,DUM) CREST(6,1) = DCMPLX(ONE/RTTWO,ZERO) CREST(6,2) = DCMPLX(ONE/TWO,-ONE/TWO) CCORX(6,1) = DCMPLX(ONE/RTTWO,-TWO+RTTWO) CCORX(6,2) = DCMPLX(-ONE+ONE/RTTWO,TWO+THREE/RTTWO) CCORX(6,3) = DCMPLX(ONE-THREE/RTTWO,ONE+ONE/RTTWO) CCORX(6,4) = CENTX(6,4) CCORX(6,5) = CENTX(6,5) CCORY(6,1) = DCMPLX(TWO,ONE+RTTWO) CCORY(6,2) = DCMPLX(ONE-THREE/RTTWO,ONE/RTTWO-TWO) CCORY(6,3) = DCMPLX(RTTWO+ONE/TWO,-RTTWO-THREE/TWO) CCORY(6,4) = CENTY(6,4) CCORY(6,5) = CENTY(6,5) * CALL CPYRWC(CENTX,NCENTX,1,7) CENTX(7,1) = DCMPLX(TWO,FOUR) CALL CPYRWC(CENTY,NCENTY,1,7) CALL INIT(7,NININT,ININT,5,-1,-1,DUM,DUM,DUM) CREST(7,1) = DCMPLX(ONE/TWO,ONE/TWO) CREST(7,2) = DCMPLX(-ONE/RTTWO,ZERO) CCORX(7,1) = DCMPLX(-ONE,THREE-RTTWO) CCORX(7,2) = DCMPLX(-ONE+THREE/RTTWO,TWO-ONE/RTTWO) CCORX(7,3) = DCMPLX(-TWO-RTTWO,-ONE+RTTWO) CCORX(7,4) = DCMPLX(-ONE-TWO*RTTWO,THREE-ONE/RTTWO) CCORX(7,5) = DCMPLX(ONE/TWO+THREE/RTTWO,ONE/TWO+THREE/RTTWO) CCORY(7,1) = DCMPLX(ONE+RTTWO,ONE+TWO*RTTWO) CCORY(7,2) = DCMPLX(-ONE+ONE/RTTWO,TWO+THREE/RTTWO) CCORY(7,3) = DCMPLX(-THREE/RTTWO,-TWO+ONE/RTTWO) CCORY(7,4) = DCMPLX(FIVE/TWO+RTTWO,TWO*RTTWO-THREE/TWO) CCORY(7,5) = DCMPLX(ONE/RTTWO-THREE,ZERO) * CALL CPYRWC(CENTX,NCENTX,1,8) CALL CPYRWC(CENTY,NCENTY,1,8) CALL INIT(8,NININT,ININT,5,-1,1,DUM,DUM,DUM) CREST(8,1) = DCMPLX(ONE/TWO,-ONE/TWO) CREST(8,2) = DCMPLX(ONE/RTTWO,ZERO) CCORX(8,1) = DCMPLX(THREE/TWO-THREE/RTTWO,ONE/TWO-THREE/RTTWO) CCORX(8,2) = DCMPLX(TWO+TWO*RTTWO,ONE+ONE/RTTWO) CCORX(8,3) = DCMPLX(RTTWO-ONE,TWO-RTTWO) CCORX(8,4) = DCMPLX(THREE-THREE/RTTWO,ONE+ONE/RTTWO) CCORX(8,5) = DCMPLX(ONE/TWO,RTTWO-ONE/TWO) CCORY(8,1) = DCMPLX(-ONE-ONE/RTTWO,ONE) CCORY(8,2) = DCMPLX(-TWO-RTTWO,-ONE-TWO*RTTWO) CCORY(8,3) = DCMPLX(TWO+THREE/RTTWO,-ONE/RTTWO) CCORY(8,4) = DCMPLX(THREE/TWO-ONE/RTTWO,FIVE/TWO-THREE/RTTWO) CCORY(8,5) = DCMPLX(-ONE/RTTWO,-THREE-RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,9) CALL CPYRWC(CENTY,NCENTY,1,9) CALL INIT(9,NININT,ININT,5,1,-1,DUM,DUM,DUM) CREST(9,1) = DCMPLX(ONE/TWO,-ONE/TWO) CREST(9,2) = DCMPLX(ONE/RTTWO,ZERO) CCORX(9,1) = DCMPLX(THREE/TWO-THREE/RTTWO,ONE/TWO-THREE/RTTWO) CCORX(9,2) = DCMPLX(TWO+TWO*RTTWO,ONE+ONE/RTTWO) CCORX(9,3) = DCMPLX(RTTWO-ONE,TWO-RTTWO) CCORX(9,4) = DCMPLX(THREE-THREE/RTTWO,ONE+ONE/RTTWO) CCORX(9,5) = DCMPLX(ONE/TWO,RTTWO-ONE/TWO) CCORY(9,1) = DCMPLX(-ONE-ONE/RTTWO,ONE) CCORY(9,2) = DCMPLX(-TWO-RTTWO,-ONE-TWO*RTTWO) CCORY(9,3) = DCMPLX(TWO+THREE/RTTWO,-ONE/RTTWO) CCORY(9,4) = DCMPLX(THREE/TWO-ONE/RTTWO,FIVE/TWO-THREE/RTTWO) CCORY(9,5) = DCMPLX(-ONE/RTTWO,-THREE-RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,10) CALL CPYRWC(CENTY,NCENTY,1,10) CALL INIT(10,NININT,ININT,3,1,2,DUM,DUM,DUM) CREST(10,1) = DCMPLX(ONE/TWO,ONE/TWO) CREST(10,2) = DCMPLX(ONE/RTTWO,ZERO) CCORX(10,1) = DCMPLX(-ONE/TWO,THREE/TWO+RTTWO) CCORX(10,2) = DCMPLX(RTTWO-ONE,TWO-RTTWO) CCORX(10,3) = DCMPLX(-TWO-THREE/RTTWO,-ONE-THREE/RTTWO) CCORX(10,4) = CENTX(10,4) CCORX(10,5) = CENTX(10,5) CCORY(10,1) = DCMPLX(ONE-ONE/RTTWO,ONE-RTTWO) CCORY(10,2) = CENTY(10,2) CCORY(10,3) = DCMPLX(-ONE/RTTWO,-TWO-THREE/RTTWO) CCORY(10,4) = CENTY(10,4) CCORY(10,5) = DCMPLX(-THREE+THREE/RTTWO,-ONE/RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,11) CALL CPYRWC(CENTY,NCENTY,1,11) CALL INIT(11,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(11,1) = DCMPLX(ONE/TWO,-ONE/TWO) CREST(11,2) = DCMPLX(ONE/TWO,-ONE/TWO) CCORX(11,1) = DCMPLX(FIVE/TWO,THREE/TWO) CCORX(11,2) = DCMPLX(ONE,THREE) CCORX(11,3) = DCMPLX(-ONE,ZERO) CCORX(11,4) = DCMPLX(ELEVEN/TWO,-ONE/TWO) CCORX(11,5) = DCMPLX(-FIVE/TWO,-ONE/TWO) CCORY(11,1) = DCMPLX(-ONE/TWO,-ONE/TWO) CCORY(11,2) = DCMPLX(-ONE,-THREE) CCORY(11,3) = DCMPLX(FOUR,ONE) CCORY(11,4) = DCMPLX(FIVE/TWO,-ONE/TWO) CCORY(11,5) = DCMPLX(-ONE/TWO,-SEVEN/TWO) * CALL CPYRWC(CENTX,NCENTX,1,12) CALL CPYRWC(CENTY,NCENTY,1,12) CALL INIT(12,NININT,ININT,3,2,1,DUM,DUM,DUM) CREST(12,1) = DCMPLX(ONE/TWO,-ONE/TWO) CREST(12,2) = DCMPLX(ONE/TWO,-ONE/TWO) CCORX(12,1) = DCMPLX(FIVE/TWO,THREE/TWO) CCORX(12,2) = CENTX(12,2) CCORX(12,3) = DCMPLX(-TWO,FOUR) CCORX(12,4) = CENTX(12,4) CCORX(12,5) = DCMPLX(ONE/TWO,-FIVE/TWO) CCORY(12,1) = DCMPLX(-ONE/TWO,-ONE/TWO) CCORY(12,2) = CZERO CCORY(12,3) = DCMPLX(THREE/TWO,-ONE/TWO) CCORY(12,4) = CENTY(12,4) CCORY(12,5) = CENTY(12,5) * CALL CPYRWC(CENTX,NCENTX,1,13) CALL CPYRWC(CENTY,NCENTY,1,13) CALL INIT(13,NININT,ININT,0,1,1,DUM,DUM,DUM) CREST(13,1) = DCMPLX(ONE/FIVE,TWO/FIVE) CREST(13,2) = DCMPLX(FOUR/FIVE,-TWO/FIVE) CCORX(13,1) = CENTX(13,1) CCORX(13,2) = CENTX(13,2) CCORX(13,3) = CENTX(13,3) CCORX(13,4) = CENTX(13,4) CCORX(13,5) = CENTX(13,5) CCORY(13,1) = CENTY(13,1) CCORY(13,2) = CENTY(13,2) CCORY(13,3) = CENTY(13,3) CCORY(13,4) = CENTY(13,4) CCORY(13,5) = CENTY(13,5) * * Perform (CROT) F06HPF tests. CALL CHECK1('F06HPF',N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CSROT) F06KPF tests. N = 15 NCENTX = 5 NCCORX = 5 NCENTY = 5 NCCORY = 5 NRREST = 2 NRCORR = 0 NININT = 3 CENTX(1,1) = DCMPLX(ONE,TWO) CENTX(1,2) = DCMPLX(TWO,THREE) CENTX(1,3) = DCMPLX(THREE,FOUR) CENTX(1,4) = DCMPLX(-THREE,-FOUR) CENTX(1,5) = DCMPLX(-ONE,-TWO) CENTY(1,1) = DCMPLX(TWO,-ONE) CENTY(1,2) = DCMPLX(THREE,-FOUR) CENTY(1,3) = DCMPLX(-TWO,TWO) CENTY(1,4) = DCMPLX(FOUR,ONE) CENTY(1,5) = DCMPLX(-ONE,-ONE) CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) RREST(1,1) = ONE/RTTWO RREST(1,2) = -ONE/RTTWO CCORX(1,1) = DCMPLX(-ONE/RTTWO,THREE/RTTWO) CCORX(1,2) = DCMPLX(-ONE/RTTWO,SEVEN/RTTWO) CCORX(1,3) = DCMPLX(FIVE/RTTWO,RTTWO) CCORX(1,4) = DCMPLX(-SEVEN/RTTWO,-FIVE/RTTWO) CCORX(1,5) = DCMPLX(ZERO,-ONE/RTTWO) CCORY(1,1) = DCMPLX(THREE/RTTWO,ONE/RTTWO) CCORY(1,2) = DCMPLX(FIVE/RTTWO,-ONE/RTTWO) CCORY(1,3) = DCMPLX(ONE/RTTWO,SIX/RTTWO) CCORY(1,4) = DCMPLX(ONE/RTTWO,-THREE/RTTWO) CCORY(1,5) = DCMPLX(-TWO/RTTWO,-THREE/RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTY,NCENTY,1,2) CALL INIT(2,NININT,ININT,5,-1,-1,DUM,DUM,DUM) RREST(2,1) = ONE RREST(2,2) = ZERO DO 160 I = 1, NCCORX CCORX(2,I) = CENTX(2,I) 160 CONTINUE DO 180 I = 1, NCCORY CCORY(2,I) = CENTY(2,I) 180 CONTINUE * CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTY,NCENTY,1,3) CALL INIT(3,NININT,ININT,3,-2,2,DUM,DUM,DUM) RREST(3,1) = THREE/FIVE RREST(3,2) = FOUR/FIVE CCORX(3,1) = DCMPLX(-ONE/FIVE,TWO/FIVE) CCORX(3,2) = CENTX(3,2) CCORX(3,3) = DCMPLX(ONE/FIVE,FOUR) CCORX(3,4) = CENTX(3,4) CCORX(3,5) = DCMPLX(ONE,-TWO) CCORY(3,1) = DCMPLX(TWO,ONE) CCORY(3,2) = CENTY(3,2) CCORY(3,3) = DCMPLX(-18/FIVE,-TWO) CCORY(3,4) = CENTY(3,4) CCORY(3,5) = DCMPLX(-SEVEN/FIVE,-ELEVEN/FIVE) * CALL CPYRWC(CENTX,NCENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,4) CALL INIT(4,NININT,ININT,2,3,-1,DUM,DUM,DUM) RREST(4,1) = ONE/TWO RREST(4,2) = RTTHR/TWO CCORX(4,1) = DCMPLX((ONE+THREE*RTTHR)/TWO,(TWO-FOUR*RTTHR)/TWO) CCORX(4,2) = CENTX(4,2) CCORX(4,3) = CENTX(4,3) CCORX(4,4) = DCMPLX((-THREE+TWO*RTTHR)/TWO,(-FOUR-RTTHR)/TWO) CCORX(4,5) = CENTX(4,5) CCORY(4,1) = DCMPLX(ONE+THREE*RTTHR/TWO,-ONE/TWO+TWO*RTTHR) CCORY(4,2) = DCMPLX((THREE-RTTHR)/TWO,-TWO-RTTHR) CCORY(4,3) = CENTY(4,3) CCORY(4,4) = CENTY(4,4) CCORY(4,5) = CENTY(4,5) * CALL CPYRWC(CENTX,NCENTX,1,5) CALL CPYRWC(CENTY,NCENTY,1,5) CALL INIT(5,NININT,ININT,5,1,1,DUM,DUM,DUM) RREST(5,1) = ZERO RREST(5,2) = ONE DO 200 I = 1, NCCORX CCORX(5,I) = CENTY(5,I) 200 CONTINUE DO 220 I = 1, NCCORY CCORY(5,I) = -CENTX(5,I) 220 CONTINUE * CALL CPYRWC(CENTX,NCENTX,1,6) CALL CPYRWC(CENTY,NCENTY,1,6) CALL INIT(6,NININT,ININT,5,-1,-1,DUM,DUM,DUM) RREST(6,1) = ZERO RREST(6,2) = ONE CALL CPYRWC(CCORX,NCCORX,5,6) CALL CPYRWC(CCORY,NCCORY,5,6) * CALL CPYRWC(CENTX,NCENTX,1,7) CALL CPYRWC(CENTY,NCENTY,1,7) CALL INIT(7,NININT,ININT,5,-1,1,DUM,DUM,DUM) RREST(7,1) = ZERO RREST(7,2) = ONE DO 240 I = 1, NCCORX CCORX(7,I) = CENTY(7,NCCORX+1-I) 240 CONTINUE DO 260 I = 1, NCCORY CCORY(7,I) = -CENTX(7,NCCORY+1-I) 260 CONTINUE * CALL CPYRWC(CENTX,NCENTX,1,8) CALL CPYRWC(CENTY,NCENTY,1,8) CALL INIT(8,NININT,ININT,5,1,-1,DUM,DUM,DUM) RREST(8,1) = ZERO RREST(8,2) = ONE CALL CPYRWC(CCORX,NCCORX,7,8) CALL CPYRWC(CCORY,NCCORY,7,8) * CALL CPYRWC(CENTX,NCENTX,1,9) CALL CPYRWC(CENTY,NCENTY,1,9) CALL INIT(9,NININT,ININT,3,1,2,DUM,DUM,DUM) RREST(9,1) = ZERO RREST(9,2) = ONE CCORX(9,1) = CENTY(9,1) CCORX(9,2) = CENTY(9,3) CCORX(9,3) = CENTY(9,5) CCORX(9,4) = CENTX(9,4) CCORX(9,5) = CENTX(9,5) CCORY(9,1) = -CENTX(9,1) CCORY(9,2) = CENTY(9,2) CCORY(9,3) = -CENTX(9,2) CCORY(9,4) = CENTY(9,4) CCORY(9,5) = -CENTX(9,3) * CALL CPYRWC(CENTX,NCENTX,1,10) CALL CPYRWC(CENTY,NCENTY,1,10) CALL INIT(10,NININT,ININT,5,1,1,DUM,DUM,DUM) RREST(10,1) = ZERO RREST(10,2) = -ONE DO 280 I = 1, NCCORX CCORX(10,I) = -CENTY(10,I) 280 CONTINUE DO 300 I = 1, NCCORY CCORY(10,I) = CENTX(10,I) 300 CONTINUE * CALL CPYRWC(CENTX,NCENTX,1,11) CALL CPYRWC(CENTY,NCENTY,1,11) CALL INIT(11,NININT,ININT,5,-1,-1,DUM,DUM,DUM) RREST(11,1) = ZERO RREST(11,2) = -ONE CALL CPYRWC(CCORX,NCCORX,10,11) CALL CPYRWC(CCORY,NCCORY,10,11) * CALL CPYRWC(CENTX,NCENTX,1,12) CALL CPYRWC(CENTY,NCENTY,1,12) CALL INIT(12,NININT,ININT,5,-1,1,DUM,DUM,DUM) RREST(12,1) = ZERO RREST(12,2) = -ONE DO 320 I = 1, NCCORX CCORX(12,I) = -CENTY(12,NCCORX+1-I) 320 CONTINUE DO 340 I = 1, NCCORY CCORY(12,I) = CENTX(12,NCCORY+1-I) 340 CONTINUE * CALL CPYRWC(CENTX,NCENTX,1,13) CALL CPYRWC(CENTY,NCENTY,1,13) CALL INIT(13,NININT,ININT,5,1,-1,DUM,DUM,DUM) RREST(13,1) = ZERO RREST(13,2) = -ONE CALL CPYRWC(CCORX,NCCORX,12,13) CALL CPYRWC(CCORY,NCCORY,12,13) * CALL CPYRWC(CENTX,NCENTX,1,14) CALL CPYRWC(CENTY,NCENTY,1,14) CALL INIT(14,NININT,ININT,3,1,2,DUM,DUM,DUM) RREST(14,1) = ZERO RREST(14,2) = -ONE CCORX(14,1) = -CENTY(14,1) CCORX(14,2) = -CENTY(14,3) CCORX(14,3) = -CENTY(14,5) CCORX(14,4) = CENTX(14,4) CCORX(14,5) = CENTX(14,5) CCORY(14,1) = CENTX(14,1) CCORY(14,2) = CENTY(14,2) CCORY(14,3) = CENTX(14,2) CCORY(14,4) = CENTY(14,4) CCORY(14,5) = CENTX(14,3) * CALL CPYRWC(CENTX,NCENTX,1,15) CALL CPYRWC(CENTY,NCENTY,1,15) CALL INIT(15,NININT,ININT,0,1,1,DUM,DUM,DUM) RREST(15,1) = ONE/RTTWO RREST(15,2) = ONE/RTTWO CALL CPYRWC(CCORX,NCCORX,2,15) CALL CPYRWC(CCORY,NCCORY,2,15) * * Perform (CSROT) F06KPF tests. CALL CHECK3('F06KPF',N,NCENTX,CENTX,NCENTY,CENTY,NRREST,RREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NRCORR,RCORR,TOL) * * Initialise data for (CDSCL) F06HCF tests N = 7 NCENTX = 5 NCCORX = 0 NCENTY = 5 NCCORY = 5 NCREST = 0 NCCORR = 0 NININT = 3 CENTX(1,1) = DCMPLX(FIVE,-ONE) CENTX(1,2) = DCMPLX(FOUR,TWO) CENTX(1,3) = DCMPLX(-THREE,-THREE) CENTX(1,4) = DCMPLX(TWO,-ONE) CENTX(1,5) = DCMPLX(FLMIN,ONE) CENTY(1,1) = DCMPLX(-THREE/FIVE,ZERO) CENTY(1,2) = DCMPLX(ONE,FOUR/FIVE) CENTY(1,3) = DCMPLX(ZERO,-ONE) CENTY(1,4) = DCMPLX(-TWO/FIVE,ONE) CENTY(1,5) = DCMPLX(FLMAX,ONE) CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) CCORY(1,1) = DCMPLX(-THREE,THREE/FIVE) CCORY(1,2) = DCMPLX(TWELVE/FIVE,26/FIVE) CCORY(1,3) = DCMPLX(-THREE,THREE) CCORY(1,4) = DCMPLX(ONE/FIVE,TWELVE/FIVE) CCORY(1,5) = DCMPLX(ZERO,FLMAX) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTY,NCENTY,1,2) CALL INIT(2,NININT,ININT,5,-1,-1,DUM,DUM,DUM) CCORY(2,1) = DCMPLX(-THREE,THREE/FIVE) CCORY(2,2) = DCMPLX(TWELVE/FIVE,26/FIVE) CCORY(2,3) = DCMPLX(-THREE,THREE) CCORY(2,4) = DCMPLX(ONE/FIVE,TWELVE/FIVE) CCORY(2,5) = DCMPLX(ZERO,FLMAX) * CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTY,NCENTY,1,3) CALL INIT(3,NININT,ININT,3,-2,-1,DUM,DUM,DUM) CCORY(3,1) = DCMPLX(-THREE,THREE/FIVE) CCORY(3,2) = DCMPLX(-THREE/FIVE,-27/FIVE) CCORY(3,3) = DCMPLX(ONE,-FLMIN) CCORY(3,4) = CENTY(3,4) CCORY(3,5) = CENTY(3,5) * CALL CPYRWC(CENTX,NCENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,4) CALL INIT(4,NININT,ININT,2,3,-1,DUM,DUM,DUM) CCORY(4,1) = DCMPLX(-SIX/FIVE,THREE/FIVE) CCORY(4,2) = DCMPLX(29/FIVE,THREE) CCORY(4,3) = CENTY(4,3) CCORY(4,4) = CENTY(4,4) CCORY(4,5) = CENTY(4,5) * CALL CPYRWC(CENTX,NCENTX,1,5) CALL CPYRWC(CENTY,NCENTY,1,5) CALL INIT(5,NININT,ININT,3,0,1,DUM,DUM,DUM) CCORY(5,1) = DCMPLX(-THREE,THREE/FIVE) CCORY(5,2) = DCMPLX(29/FIVE,THREE) CCORY(5,3) = DCMPLX(-ONE,-FIVE) CCORY(5,4) = CENTY(5,4) CCORY(5,5) = CENTY(5,5) * CALL CPYRWC(CENTX,NCENTX,1,6) CALL CPYRWC(CENTY,NCENTY,1,6) CALL INIT(6,NININT,ININT,2,1,2,DUM,DUM,DUM) CCORY(6,1) = DCMPLX(-THREE,THREE/FIVE) CCORY(6,2) = CENTY(6,2) CCORY(6,3) = DCMPLX(TWO,-FOUR) CCORY(6,4) = CENTY(6,4) CCORY(6,5) = CENTY(6,5) * CALL CPYRWC(CENTX,NCENTX,1,7) CALL CPYRWC(CENTY,NCENTY,1,7) CALL INIT(7,NININT,ININT,0,3,-1,DUM,DUM,DUM) CCORY(7,1) = CENTY(7,1) CCORY(7,2) = CENTY(7,2) CCORY(7,3) = CENTY(7,3) CCORY(7,4) = CENTY(7,4) CCORY(7,5) = CENTY(7,5) * * Perform (CDSCL) F06HCF tests. CALL CHECK1('F06HCF',N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CSDSCL) F06KCF tests. N = 6 NRENTX = 5 NRCORX = 0 NCENTY = 5 NCCORY = 5 NCREST = 0 NCCORR = 0 NININT = 3 RENTX(1,1) = -FIVE RENTX(1,2) = TWO RENTX(1,3) = -ONE RENTX(1,4) = THREE RENTX(1,5) = -FLMIN CENTY(1,1) = DCMPLX(-THREE/FIVE,ZERO) CENTY(1,2) = DCMPLX(ONE,FOUR/FIVE) CENTY(1,3) = DCMPLX(ZERO,-ONE) CENTY(1,4) = DCMPLX(-TWO/FIVE,ONE) CENTY(1,5) = DCMPLX(FLMAX,ONE) CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) CCORY(1,1) = DCMPLX(THREE,ZERO) CCORY(1,2) = DCMPLX(TWO,EIGHT/FIVE) CCORY(1,3) = DCMPLX(ZERO,ONE) CCORY(1,4) = DCMPLX(-SIX/FIVE,THREE) CCORY(1,5) = DCMPLX(-ONE,-FLMIN) * CALL CPYRWR(RENTX,NRENTX,1,2) CALL CPYRWC(CENTY,NCENTY,1,2) CALL INIT(2,NININT,ININT,5,-1,-1,DUM,DUM,DUM) CCORY(2,1) = DCMPLX(THREE,ZERO) CCORY(2,2) = DCMPLX(TWO,EIGHT/FIVE) CCORY(2,3) = DCMPLX(ZERO,ONE) CCORY(2,4) = DCMPLX(-SIX/FIVE,THREE) CCORY(2,5) = DCMPLX(-ONE,-FLMIN) * CALL CPYRWR(RENTX,NRENTX,1,3) CALL CPYRWC(CENTY,NCENTY,1,3) CALL INIT(3,NININT,ININT,3,1,-1,DUM,DUM,DUM) CCORY(3,1) = DCMPLX(THREE/FIVE,ZERO) CCORY(3,2) = DCMPLX(TWO,EIGHT/FIVE) CCORY(3,3) = DCMPLX(ZERO,FIVE) CCORY(3,4) = CENTY(3,4) CCORY(3,5) = CENTY(3,5) * CALL CPYRWR(RENTX,NRENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,4) CALL INIT(4,NININT,ININT,2,-3,3,DUM,DUM,DUM) CCORY(4,1) = DCMPLX(-NINE/FIVE,ZERO) CCORY(4,2) = CENTY(4,2) CCORY(4,3) = CENTY(4,3) CCORY(4,4) = DCMPLX(TWO,-FIVE) CCORY(4,5) = CENTY(4,5) * CALL CPYRWR(RENTX,NRENTX,1,5) CALL CPYRWC(CENTY,NCENTY,1,5) CALL INIT(5,NININT,ININT,4,0,1,DUM,DUM,DUM) CCORY(5,1) = DCMPLX(THREE,ZERO) CCORY(5,2) = DCMPLX(-FIVE,-FOUR) CCORY(5,3) = DCMPLX(ZERO,FIVE) CCORY(5,4) = DCMPLX(TWO,-FIVE) CCORY(5,5) = CENTY(5,5) * CALL CPYRWR(RENTX,NRENTX,1,6) CALL CPYRWC(CENTY,NCENTY,1,6) CALL INIT(6,NININT,ININT,0,1,1,DUM,DUM,DUM) CCORY(6,1) = CENTY(6,1) CCORY(6,2) = CENTY(6,2) CCORY(6,3) = CENTY(6,3) CCORY(6,4) = CENTY(6,4) CCORY(6,5) = CENTY(6,5) * * Perform (CSDSCL) F06KCF tests. CALL CHECK2('F06KCF',N,NRENTX,RENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NRCORX,RCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CNEGV) F06HGF tests. N = 2 NCENTX = 5 NCCORX = 5 NCENTY = 0 NCCORY = 0 NCREST = 0 NCCORR = 0 NININT = 2 CENTX(1,1) = DCMPLX(ONE,ZERO) CENTX(1,2) = DCMPLX(ZERO,-ONE) CENTX(1,3) = DCMPLX(ONE,TWO) CENTX(1,4) = DCMPLX(-TWO,ONE) CENTX(1,5) = DCMPLX(THREE,FOUR) CALL INIT(1,NININT,ININT,5,1,DUM,DUM,DUM,DUM) CCORX(1,1) = DCMPLX(-ONE,ZERO) CCORX(1,2) = DCMPLX(ZERO,ONE) CCORX(1,3) = DCMPLX(-ONE,-TWO) CCORX(1,4) = DCMPLX(TWO,-ONE) CCORX(1,5) = DCMPLX(-THREE,-FOUR) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL INIT(2,NININT,ININT,3,2,DUM,DUM,DUM,DUM) CCORX(2,1) = DCMPLX(-ONE,ZERO) CCORX(2,2) = DCMPLX(ZERO,-ONE) CCORX(2,3) = DCMPLX(-ONE,-TWO) CCORX(2,4) = DCMPLX(-TWO,ONE) CCORX(2,5) = DCMPLX(-THREE,-FOUR) * * Perform (CNEGV) F06HGF tests. CALL CHECK1('F06HGF',N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CSSCMV) F06KDF tests. N = 6 NCENTX = 5 NCCORX = 0 NCENTY = 5 NCCORY = 5 NRREST = 1 NRCORR = 0 NININT = 3 CENTX(1,1) = DCMPLX(ONE,TWO) CENTX(1,2) = DCMPLX(TWO,-ONE) CENTX(1,3) = DCMPLX(FLMIN,-FLMIN) CENTX(1,4) = DCMPLX(THREE,FOUR) CENTX(1,5) = DCMPLX(-FLMAX,ONE) DO 360 I = 1, NCCORY CENTY(1,I) = CZERO 360 CONTINUE CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTX,NCENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,2) CALL CPYRWC(CENTY,NCENTY,1,3) CALL CPYRWC(CENTY,NCENTY,1,4) CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) RREST(1,1) = ONE CCORY(1,1) = CENTX(1,1) CCORY(1,2) = CENTX(1,2) CCORY(1,3) = CENTX(1,3) CCORY(1,4) = CENTX(1,4) CCORY(1,5) = CENTX(1,5) * CALL INIT(2,NININT,ININT,4,-1,-1,DUM,DUM,DUM) RREST(2,1) = FLMAX/EIGHT CCORY(2,1) = DCMPLX(FLMAX/EIGHT,FLMAX/FOUR) CCORY(2,2) = DCMPLX(FLMAX/FOUR,-FLMAX/EIGHT) CCORY(2,3) = DCMPLX(ONE/EIGHT,-ONE/EIGHT) CCORY(2,4) = DCMPLX(RREST(2,1)*THREE,FLMAX/TWO) CCORY(2,5) = CENTY(2,5) * CALL INIT(3,NININT,ININT,3,-1,2,DUM,DUM,DUM) RREST(3,1) = TEN CCORY(3,1) = DCMPLX(TEN*FLMIN,-TEN*FLMIN) CCORY(3,2) = CENTY(3,2) CCORY(3,3) = DCMPLX(TWO*TEN,-TEN) CCORY(3,4) = CENTY(3,4) CCORY(3,5) = DCMPLX(TEN,TWO*TEN) * CALL INIT(4,NININT,ININT,2,2,-4,DUM,DUM,DUM) RREST(4,1) = FLMIN CCORY(4,1) = CZERO CCORY(4,2) = CENTY(4,2) CCORY(4,3) = CENTY(4,3) CCORY(4,4) = CENTY(4,4) CCORY(4,5) = DCMPLX(FLMIN,TWO*FLMIN) * CALL INIT(5,NININT,ININT,5,1,1,DUM,DUM,DUM) RREST(5,1) = ZERO CCORY(5,1) = CZERO CCORY(5,2) = CZERO CCORY(5,3) = CZERO CCORY(5,4) = CZERO CCORY(5,5) = CZERO * CALL INIT(6,NININT,ININT,0,1,1,DUM,DUM,DUM) RREST(6,1) = TWO CCORY(6,1) = CENTY(6,1) CCORY(6,2) = CENTY(6,2) CCORY(6,3) = CENTY(6,3) CCORY(6,4) = CENTY(6,4) CCORY(6,5) = CENTY(6,5) * * Perform (CSSCMV) F06KDF tests. CALL CHECK3('F06KDF',N,NCENTX,CENTX,NCENTY,CENTY,NRREST,RREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NRCORR,RCORR,TOL) * * Initialise data for (CSCMV) F06HDF tests N = 6 NCENTX = 5 NCCORX = 0 NCENTY = 5 NCCORY = 5 NCREST = 1 NCCORR = 0 NININT = 3 CENTX(1,1) = DCMPLX(ONE,TWO) CENTX(1,2) = DCMPLX(TWO,-ONE) CENTX(1,3) = DCMPLX(FLMIN,-FLMIN) CENTX(1,4) = DCMPLX(THREE,FOUR) CENTX(1,5) = DCMPLX(-FLMAX,ONE) DO 380 I = 1, NCENTY CENTY(1,I) = CZERO 380 CONTINUE CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(1,1) = DCMPLX(ONE,ZERO) CCORY(1,1) = CENTX(1,1) CCORY(1,2) = CENTX(1,2) CCORY(1,3) = CENTX(1,3) CCORY(1,4) = CENTX(1,4) CCORY(1,5) = CENTX(1,5) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTY,NCENTY,1,2) CALL INIT(2,NININT,ININT,4,-1,-1,DUM,DUM,DUM) CREST(2,1) = DCMPLX(FLMAX/EIGHT,FLMAX/16) CCORY(2,1) = DCMPLX(ZERO,(FLMAX/16)*FIVE) CCORY(2,2) = DCMPLX((FLMAX/16)*FIVE,ZERO) CCORY(2,3) = DCMPLX(THREE/16,-ONE/16) CCORY(2,4) = DCMPLX(FLMAX/EIGHT,(FLMAX/16)*ELEVEN) CCORY(2,5) = CENTY(2,5) * CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTY,NCENTY,1,3) CALL INIT(3,NININT,ININT,3,-1,2,DUM,DUM,DUM) CREST(3,1) = DCMPLX(-FIVE,TEN) CCORY(3,1) = DCMPLX(FIVE*FLMIN,15*FLMIN) CCORY(3,2) = CENTY(3,2) CCORY(3,3) = DCMPLX(ZERO,FIVE*FIVE) CCORY(3,4) = CENTY(3,4) CCORY(3,5) = DCMPLX(-FIVE*FIVE,ZERO) * CALL CPYRWC(CENTX,NCENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,4) CALL INIT(4,NININT,ININT,2,2,-4,DUM,DUM,DUM) CREST(4,1) = DCMPLX(FLMIN,FLMIN) CCORY(4,1) = CZERO CCORY(4,2) = CENTY(4,2) CCORY(4,3) = CENTY(4,3) CCORY(4,4) = CENTY(4,4) CCORY(4,5) = DCMPLX(-FLMIN,THREE*FLMIN) * CALL CPYRWC(CENTX,NCENTX,1,5) CALL CPYRWC(CENTY,NCENTY,1,5) CALL INIT(5,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(5,1) = CZERO CCORY(5,1) = CZERO CCORY(5,2) = CZERO CCORY(5,3) = CZERO CCORY(5,4) = CZERO CCORY(5,5) = CZERO * CALL CPYRWC(CENTX,NCENTX,1,6) CALL CPYRWC(CENTY,NCENTY,1,6) CALL INIT(6,NININT,ININT,0,1,1,DUM,DUM,DUM) CREST(6,1) = DCMPLX(FLMIN,FLMIN) CCORY(6,1) = CENTY(6,1) CCORY(6,2) = CENTY(6,2) CCORY(6,3) = CENTY(6,3) CCORY(6,4) = CENTY(6,4) CCORY(6,5) = CENTY(6,5) * * Perform (CSCMV) F06HDF tests. CALL CHECK1('F06HDF',N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CGRF) F06HTF tests. N = 7 NCENTX = 5 NCCORX = 5 NCENTY = 5 NCCORY = 0 NCREST = 2 NCCORR = 1 NININT = 3 CENTX(1,1) = DCMPLX(TWO,ONE) CENTX(1,2) = DCMPLX(THREE,ZERO) CENTX(1,3) = DCMPLX(ONE,-ONE) CENTX(1,4) = DCMPLX(ZERO,ZERO) CENTX(1,5) = DCMPLX(TWO,ONE) CENTY(1,1) = DCMPLX(-ONE,TWO) CENTY(1,2) = DCMPLX(ZERO,TWO) CENTY(1,3) = DCMPLX(TWO,ONE) CENTY(1,4) = DCMPLX(-ONE,-TWO) CENTY(1,5) = DCMPLX(-ONE,-ONE) CALL INIT(1,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(1,1) = DCMPLX(TWO,-TWO) CREST(1,2) = DCMPLX(ONE,TWO) CCORX(1,1) = DCMPLX(TWO,-SEVEN*TEN-FOUR) CCORX(1,2) = DCMPLX(-THREE*NINE,-SIX*TEN) CCORX(1,3) = DCMPLX(-SEVEN*TEN-FOUR,-ONE) CCORX(1,4) = DCMPLX(SIX*TEN,NINE*FIVE) CCORX(1,5) = DCMPLX(NINE*FIVE+TWO,EIGHT*TWO) CCORR(1,1) = DCMPLX(-FOUR*SEVEN,THRTEN) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL CPYRWC(CENTY,NCENTY,1,2) CALL INIT(2,NININT,ININT,3,-1,-1,DUM,DUM,DUM) CREST(2,1) = DCMPLX(-ONE,ZERO) CREST(2,2) = DCMPLX(ONE,-ONE) CCORX(2,1) = DCMPLX(-FOUR*TEN,FIVE*THREE) CCORX(2,2) = DCMPLX(-FIVE*FIVE,FOUR*SEVEN) CCORX(2,3) = DCMPLX(THREE*FIVE,FOUR*TEN+ONE) CCORX(2,4) = CENTX(2,4) CCORX(2,5) = CENTX(2,5) CCORR(2,1) = DCMPLX(THRTEN,FOUR+TEN) * CALL CPYRWC(CENTX,NCENTX,1,3) CALL CPYRWC(CENTY,NCENTY,1,3) CALL INIT(3,NININT,ININT,3,2,-1,DUM,DUM,DUM) CREST(3,1) = DCMPLX(ZERO,TWO) CREST(3,2) = DCMPLX(RTTWO,ZERO) CCORX(3,1) = DCMPLX(TWO*RTTWO-ELEVEN,TWELVE-FOUR*RTTWO) CCORX(3,2) = CENTX(3,2) CCORX(3,3) = DCMPLX(FOUR*RTTWO-THRTEN,-SEVEN) CCORX(3,4) = CENTX(3,4) CCORX(3,5) = DCMPLX(FOUR*RTTWO-NINE,TWO*RTTWO-TWELVE) CCORR(3,1) = DCMPLX(-THREE*RTTWO,SEVEN*RTTWO-TWO) * CALL CPYRWC(CENTX,NCENTX,1,4) CALL CPYRWC(CENTY,NCENTY,1,4) CALL INIT(4,NININT,ININT,2,-2,3,DUM,DUM,DUM) CREST(4,1) = DCMPLX(ONE,ONE) CREST(4,2) = DCMPLX(FOUR/THREE,THREE/TWO) CCORX(4,1) = DCMPLX(FIVE/THREE,-153/SIX) CCORX(4,2) = CENTX(4,2) CCORX(4,3) = DCMPLX(-TWO*TEN,91/SIX) CCORX(4,4) = CENTX(4,4) CCORX(4,5) = CENTX(4,5) CCORR(4,1) = DCMPLX(137/NINE,71/NINE) * CALL CPYRWC(CENTX,NCENTX,1,5) CALL CPYRWC(CENTY,NCENTY,1,5) CALL INIT(5,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(5,1) = DCMPLX(ONE,ONE) CREST(5,2) = DCMPLX(-ONE/RTTWO,ONE/RTTWO) CCORX(5,1) = CENTX(5,1) CCORX(5,2) = CENTX(5,2) CCORX(5,3) = CENTX(5,3) CCORX(5,4) = CENTX(5,4) CCORX(5,5) = CENTX(5,5) CCORR(5,1) = DCMPLX(-RTTWO,ZERO) * CALL CPYRWC(CENTX,NCENTX,1,6) CALL CPYRWC(CENTY,NCENTY,1,6) CALL INIT(6,NININT,ININT,5,1,1,DUM,DUM,DUM) CREST(6,1) = DCMPLX(ONE,ONE) CREST(6,2) = CZERO CALL CPYRWC(CCORX,NCCORX,5,6) CCORR(6,1) = DCMPLX(ONE,ONE) * CENTX(7,1) = DCMPLX(-ONE,ZERO) CENTX(7,2) = DCMPLX(ONE,TWO) CENTX(7,3) = DCMPLX(-TWO,-TWO) CENTX(7,4) = DCMPLX(ZERO,-TWO) CENTX(7,5) = DCMPLX(ONE,ONE) CENTY(7,1) = DCMPLX(THREE*RTSIX*RTFIV/100,RTSIX*RTFIV/100) CENTY(7,2) = DCMPLX(-RTSIX*RTFIV/100,-SEVEN*RTSIX*RTFIV/100) CENTY(7,3) = DCMPLX(RTSIX*RTFIV/25,TWO*RTSIX*RTFIV/25) CENTY(7,4) = DCMPLX(-RTSIX*RTFIV/50,THREE*RTSIX*RTFIV/50) CENTY(7,5) = DCMPLX(-RTSIX*RTFIV/50,-RTSIX*RTFIV/25) CREST(7,1) = DCMPLX(-ONE,TWO) CREST(7,2) = DCMPLX(RTSIX/RTFIV,ONE/THREE) CALL INIT(7,NININT,ININT,5,1,1,DUM,DUM,DUM) CCORX(7,1) = CZERO CCORX(7,2) = CZERO CCORX(7,3) = CZERO CCORX(7,4) = CZERO CCORX(7,5) = CZERO CCORR(7,1) = DCMPLX(FIVE,ZERO) * * Perform (CGRF) F06HTF tests. CALL CHECK1('F06HTF',N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CGRFG) F06HRF tests. N = 11 NCENTX = 5 NCCORX = 5 NCENTY = 0 NCCORY = 0 NCREST = 1 NCCORR = 2 NININT = 2 CENTX(1,1) = DCMPLX(-ONE,ZERO) CENTX(1,2) = DCMPLX(ONE,TWO) CENTX(1,3) = DCMPLX(-TWO,-TWO) CENTX(1,4) = DCMPLX(ZERO,-TWO) CENTX(1,5) = DCMPLX(ONE,ONE) CALL INIT(1,NININT,ININT,5,1,DUM,DUM,DUM,DUM) CREST(1,1) = DCMPLX(-ONE,-TWO) CCORX(1,1) = DCMPLX(THREE*RTTHTY/100,-RTTHTY/100) CCORX(1,2) = DCMPLX(-RTTHTY/20,-RTTHTY/20) CCORX(1,3) = DCMPLX(TWO*RTTHTY/25,RTTHTY/25) CCORX(1,4) = DCMPLX(RTTHTY/50,THREE*RTTHTY/50) CCORX(1,5) = DCMPLX(-RTTHTY/25,-RTTHTY/50) CCORR(1,1) = DCMPLX(FIVE,ZERO) CCORR(1,2) = DCMPLX(RTSIX/RTFIV,-ONE/THREE) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL INIT(2,NININT,ININT,3,2,DUM,DUM,DUM,DUM) CREST(2,1) = DCMPLX(ZERO,-ONE) CCORX(2,1) = DCMPLX(TWO*RTTHR/THRTEN,-ONE/THRTEN) CCORX(2,2) = CENTX(2,2) CCORX(2,3) = DCMPLX((TWO+FOUR*RTTHR)/THRTEN,(FOUR*RTTHR-TWO) + /THRTEN) CCORX(2,4) = CENTX(2,4) CCORX(2,5) = DCMPLX((-ONE-TWO*RTTHR)/THRTEN,(ONE-TWO*RTTHR) + /THRTEN) CCORR(2,1) = DCMPLX(TWO*RTTHR,ZERO) CCORR(2,2) = DCMPLX(ONE,-ONE/(TWO*RTTHR)) * CALL CPYRWC(CENTX,NCENTX,1,3) CALL INIT(3,NININT,ININT,2,4,DUM,DUM,DUM,DUM) CREST(3,1) = DCMPLX(THREE,TWO) CCORX(3,1) = DCMPLX(-SEVEN*RTSEV/106,RTSEV/53) CCORX(3,2) = CENTX(3,2) CCORX(3,3) = CENTX(3,3) CCORX(3,4) = CENTX(3,4) CCORX(3,5) = DCMPLX(NINE*RTSEV/106,FIVE*RTSEV/106) CCORR(3,1) = DCMPLX(-FOUR,ZERO) CCORR(3,2) = DCMPLX(RTSEV/TWO,-TWO/SEVEN) * CALL CPYRWC(CENTX,NCENTX,1,4) CALL INIT(4,NININT,ININT,2,3,DUM,DUM,DUM,DUM) CREST(4,1) = DCMPLX(-TWO,ZERO) CCORX(4,1) = DCMPLX(ONE/(RTTHR*RTFIV),ZERO) CCORX(4,2) = CENTX(4,2) CCORX(4,3) = CENTX(4,3) CCORX(4,4) = DCMPLX(ZERO,TWO/(RTTHR*RTFIV)) CCORX(4,5) = CENTX(4,5) CCORR(4,1) = DCMPLX(THREE,ZERO) CCORR(4,2) = DCMPLX(RTFIV/RTTHR,ZERO) * CALL CPYRWC(CENTX,NCENTX,1,5) CALL INIT(5,NININT,ININT,0,1,DUM,DUM,DUM,DUM) CREST(5,1) = DCMPLX(ONE,ZERO) CCORX(5,1) = CENTX(5,1) CCORX(5,2) = CENTX(5,2) CCORX(5,3) = CENTX(5,3) CCORX(5,4) = CENTX(5,4) CCORX(5,5) = CENTX(5,5) CCORR(5,1) = DCMPLX(ONE,ZERO) CCORR(5,2) = CZERO * CALL CPYRWC(CENTX,NCENTX,1,6) CALL INIT(6,NININT,ININT,0,1,DUM,DUM,DUM,DUM) CREST(6,1) = DCMPLX(ONE,ONE) CALL CPYRWC(CCORX,NCCORX,5,6) CCORR(6,1) = DCMPLX(-RTTWO,ZERO) CCORR(6,2) = DCMPLX(-ONE/RTTWO,ONE/RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,7) CENTX(7,1) = CZERO CALL INIT(7,NININT,ININT,1,1,DUM,DUM,DUM,DUM) CREST(7,1) = DCMPLX(ONE,ZERO) CALL CPYRWC(CCORX,NCCORX,5,7) CCORX(7,1) = CZERO CCORR(7,1) = DCMPLX(ONE,ZERO) CCORR(7,2) = CZERO * CALL CPYRWC(CENTX,NCENTX,1,8) CENTX(8,1) = CZERO CALL INIT(8,NININT,ININT,1,1,DUM,DUM,DUM,DUM) CREST(8,1) = DCMPLX(ONE,ONE) CALL CPYRWC(CCORX,NCCORX,5,8) CCORX(8,1) = CZERO CCORR(8,1) = DCMPLX(-RTTWO,ZERO) CCORR(8,2) = DCMPLX(-ONE/RTTWO,ONE/RTTWO) * DO 400 I = 1, NCENTX CENTX(9,I) = CZERO CCORX(9,I) = CZERO 400 CONTINUE CALL INIT(9,NININT,ININT,5,1,DUM,DUM,DUM,DUM) CREST(9,1) = DCMPLX(ONE,ZERO) CCORR(9,1) = DCMPLX(ONE,ZERO) CCORR(9,2) = CZERO * CALL CPYRWC(CENTX,NCENTX,9,10) CENTX(10,1) = DCMPLX(FLMIN,FLMIN) CALL INIT(10,NININT,ININT,5,1,DUM,DUM,DUM,DUM) CREST(10,1) = DCMPLX(ONE,ONE) CALL CPYRWC(CCORX,NCCORX,9,10) CCORX(10,1) = DCMPLX(FLMIN,FLMIN) CCORR(10,1) = DCMPLX(-RTTWO,ZERO) CCORR(10,2) = DCMPLX(-ONE/RTTWO,ONE/RTTWO) * CALL CPYRWC(CENTX,NCENTX,1,11) CALL INIT(11,NININT,ININT,5,1,DUM,DUM,DUM,DUM) CREST(11,1) = CZERO CCORX(11,1) = DCMPLX(ONE/(TWO*RTFIV),ZERO) CCORX(11,2) = DCMPLX(-ONE/(TWO*RTFIV),-ONE/RTFIV) CCORX(11,3) = DCMPLX(ONE/RTFIV,ONE/RTFIV) CCORX(11,4) = DCMPLX(ZERO,ONE/RTFIV) CCORX(11,5) = DCMPLX(-ONE/(TWO*RTFIV),-ONE/(TWO*RTFIV)) CCORR(11,1) = DCMPLX(TWO*RTFIV,ZERO) CCORR(11,2) = DCMPLX(ONE,ZERO) * * Perform (CGRFG) F06HRF tests. CALL CHECK1('F06HRF',N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR,TOL) * * Initialise data for (CSROTG) F06HQF tests N = 4 NCENTX = 5 NININT = 2 * CENTX(1,1) = DCMPLX(-ONE,ZERO) CENTX(1,2) = DCMPLX(TWO,ONE) CENTX(1,3) = DCMPLX(ZERO,TWO) CENTX(1,4) = DCMPLX(-ONE,-ONE) CENTX(1,5) = DCMPLX(ONE,-TWO) CALL INIT(1,NININT,ININT,5,1,DUM,DUM,DUM,DUM) PIVOT(1) = 'F' DIRECT(1) = 'F' ALPHA(1) = DCMPLX(ONE,ONE) BETA(1) = DCMPLX(RTNNTN/RTTWO,RTNNTN/RTTWO) CORRC(1,1) = TWO/RTSIX CORRC(1,2) = RTSIX/FOUR CORRC(1,3) = TWO/RTSIX CORRC(1,4) = RTSIX/RTSEV CORRC(1,5) = RTTWO*RTSEV/RTNNTN CORRS(1,1) = DCMPLX(-ONE/RTSIX,ONE/RTSIX) CORRS(1,2) = DCMPLX(THREE/FOUR,-ONE/FOUR) CORRS(1,3) = DCMPLX(ONE/RTSIX,ONE/RTSIX) CORRS(1,4) = DCMPLX(-ONE/RTSEV,ZERO) CORRS(1,5) = DCMPLX(-ONE/(RTTWO*RTNNTN),-THREE/(RTTWO*RTNNTN)) * CALL CPYRWC(CENTX,NCENTX,1,2) CALL INIT(2,NININT,ININT,3,2,DUM,DUM,DUM,DUM) PIVOT(2) = 'F' DIRECT(2) = 'B' ALPHA(2) = DCMPLX(-ONE,ONE) BETA(2) = DCMPLX(-RTSIX,RTSIX) CORRC(2,1) = RTELEV/(RTSIX*RTTWO) CORRC(2,2) = RTSEV/RTELEV CORRC(2,3) = RTTWO/RTSEV CORRS(2,1) = DCMPLX(-ONE/(TWO*RTSIX),ONE/(TWO*RTSIX)) CORRS(2,2) = DCMPLX(-RTTWO/RTELEV,-RTTWO/RTELEV) CORRS(2,3) = DCMPLX(THREE/(RTTWO*RTSEV),ONE/(RTTWO*RTSEV)) * CALL CPYRWC(CENTX,NCENTX,1,3) CALL INIT(3,NININT,ININT,2,4,DUM,DUM,DUM,DUM) PIVOT(3) = 'V' DIRECT(3) = 'F' ALPHA(3) = DCMPLX(ZERO,-ONE) BETA(3) = DCMPLX(ZERO,-RTSEV) CORRC(3,1) = RTFIV/RTSIX CORRC(3,2) = ONE/RTSEV CORRS(3,1) = DCMPLX(ONE/(RTFIV*RTSIX),-TWO/(RTFIV*RTSIX)) CORRS(3,2) = DCMPLX(-TWO*RTSIX/(RTFIV*RTSEV),RTSIX/(RTFIV*RTSEV)) * CALL CPYRWC(CENTX,NCENTX,1,4) CALL INIT(4,NININT,ININT,2,3,DUM,DUM,DUM,DUM) PIVOT(4) = 'V' DIRECT(4) = 'B' ALPHA(4) = DCMPLX(ONE,TWO) BETA(4) = DCMPLX(TWO*RTTWO/RTFIV,FOUR*RTTWO/RTFIV) CORRC(4,1) = RTFIV/(TWO*RTTWO) CORRC(4,2) = ONE/RTTHR CORRS(4,1) = DCMPLX(-RTTHR/(TWO*RTTWO*RTFIV), + TWO*RTTHR/(TWO*RTTWO*RTFIV)) CORRS(4,2) = DCMPLX(ONE/RTTHR,ONE/RTTHR) * * Perform (CSROTG) F06HQF tests. CALL CHECK4('F06HQF',PIVOT,DIRECT,N,NCENTX,CENTX,ALPHA,BETA,CORRC, + CORRS,ININT,TOL) STOP * 99999 FORMAT (' F06HBF Example Program Results',/1X) END SUBROUTINE INIT(I,J,ININT,I1,I2,I3,I4,I5,I6) * Sets ININT (I, 1) ... ININT (I, J) to be I1, I2 ... IJ * .. Scalar Arguments .. INTEGER I, I1, I2, I3, I4, I5, I6, J * .. Array Arguments .. INTEGER ININT(15,6) * .. Executable Statements .. IF (J.GT.0) ININT(I,1) = I1 IF (J.GT.1) ININT(I,2) = I2 IF (J.GT.2) ININT(I,3) = I3 IF (J.GT.3) ININT(I,4) = I4 IF (J.GT.4) ININT(I,5) = I5 IF (J.GT.5) ININT(I,6) = I6 RETURN END SUBROUTINE CPYRWC(ENTER,LEN,FROM,TO) * Copies one row of complex ENTER to another. * .. Scalar Arguments .. INTEGER FROM, LEN, TO * .. Array Arguments .. COMPLEX*16 ENTER(15,6) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 20 I = 1, LEN ENTER(TO,I) = ENTER(FROM,I) 20 CONTINUE RETURN END SUBROUTINE CPYRWR(ENTER,LEN,FROM,TO) * Copies one row of real ENTER to another. * .. Scalar Arguments .. INTEGER FROM, LEN, TO * .. Array Arguments .. DOUBLE PRECISION ENTER(15,6) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 20 I = 1, LEN ENTER(TO,I) = ENTER(FROM,I) 20 CONTINUE RETURN END SUBROUTINE TOVECR(MATRIX,VECTOR,LEN,FROM) * Copies one row of real MATRIX to VECTOR * .. Scalar Arguments .. INTEGER FROM, LEN * .. Array Arguments .. DOUBLE PRECISION MATRIX(15,6), VECTOR(6) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 20 I = 1, LEN VECTOR(I) = MATRIX(FROM,I) 20 CONTINUE RETURN END SUBROUTINE TOVECC(MATRIX,VECTOR,LEN,FROM) * Copies one row of complex MATRIX to VECTOR * .. Scalar Arguments .. INTEGER FROM, LEN * .. Array Arguments .. COMPLEX*16 MATRIX(15,6), VECTOR(6) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 20 I = 1, LEN VECTOR(I) = MATRIX(FROM,I) 20 CONTINUE RETURN END SUBROUTINE MATRPR(N,MAT,ROW,INCX,TITLE,NSIG,NCOLS,NOUT) * Prints a single row of the real matrix MAT. * .. Scalar Arguments .. INTEGER INCX, N, NCOLS, NOUT, NSIG, ROW CHARACTER*(*) TITLE * .. Array Arguments .. DOUBLE PRECISION MAT(15,6) * .. Local Scalars .. INTEGER I * .. Local Arrays .. DOUBLE PRECISION VEC(6) * .. External Subroutines .. EXTERNAL VECPR1 * .. Executable Statements .. DO 20 I = 1, N VEC(I) = MAT(ROW,I) 20 CONTINUE CALL VECPR1(N,VEC,INCX,TITLE,NSIG,NCOLS,NOUT) RETURN END SUBROUTINE MATRPC(N,MAT,ROW,INCX,TITLE,NSIG,NCOLS,NOUT) * Prints a single row of the complex matrix MAT. * .. Scalar Arguments .. INTEGER INCX, N, NCOLS, NOUT, NSIG, ROW CHARACTER*(*) TITLE * .. Array Arguments .. COMPLEX*16 MAT(15,6) * .. Local Scalars .. INTEGER I * .. Local Arrays .. COMPLEX*16 VEC(6) * .. External Subroutines .. EXTERNAL VECPR2 * .. Executable Statements .. DO 20 I = 1, N VEC(I) = MAT(ROW,I) 20 CONTINUE CALL VECPR2(N,VEC,INCX,TITLE,NSIG,NCOLS,NOUT) RETURN END SUBROUTINE CHECK1(FUNNAM,N,NCENTX,CENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NCCORR,CCORR, + TOL) * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER N, NCCORR, NCCORX, NCCORY, NCENTX, NCENTY, + NCREST CHARACTER*6 FUNNAM * .. Array Arguments .. COMPLEX*16 CCORR(15,6), CCORX(15,6), CCORY(15,6), + CENTX(15,6), CENTY(15,6), CREST(15,6) INTEGER ININT(15,6) * .. Local Scalars .. DOUBLE PRECISION STOL INTEGER I LOGICAL FIRST, MISSED CHARACTER*15 PR * .. Local Arrays .. COMPLEX*16 COPYCR(6), COPYCX(6), COPYCY(6), CPCCRR(6), + CPCCRX(6), CPCCRY(6) * .. External Functions .. DOUBLE PRECISION X02AJF, X02AMF LOGICAL CNDIFV EXTERNAL X02AJF, X02AMF, CNDIFV * .. External Subroutines .. EXTERNAL F06HBF, F06HCF, F06HDF, F06HGF, F06HPF, F06HRF, + F06HTF, MATRPC, TOVECC, VECPR2 * .. Executable Statements .. FIRST = .TRUE. WRITE (NOUT,*) ' Testing routine ', FUNNAM DO 20 I = 1, N CALL TOVECC(CENTX,COPYCX,NCENTX,I) CALL TOVECC(CENTY,COPYCY,NCENTY,I) CALL TOVECC(CREST,COPYCR,NCREST,I) CALL TOVECC(CCORX,CPCCRX,NCCORX,I) CALL TOVECC(CCORY,CPCCRY,NCCORY,I) CALL TOVECC(CCORR,CPCCRR,NCCORR,I) IF (FUNNAM.EQ.'F06HBF') THEN CALL F06HBF(ININT(I,1),COPYCR(1),COPYCX,ININT(I,2)) ELSE IF (FUNNAM.EQ.'F06HRF') THEN STOL = X02AMF()/X02AJF() CALL F06HRF(ININT(I,1),COPYCR(1),COPYCX,ININT(I,2),STOL, + COPYCR(2)) ELSE IF (FUNNAM.EQ.'F06HPF') THEN CALL F06HPF(ININT(I,1),COPYCX,ININT(I,2),COPYCY,ININT(I,3), + COPYCR(1),COPYCR(2)) ELSE IF (FUNNAM.EQ.'F06HCF') THEN CALL F06HCF(ININT(I,1),COPYCX,ININT(I,2),COPYCY,ININT(I,3)) ELSE IF (FUNNAM.EQ.'F06HGF') THEN CALL F06HGF(ININT(I,1),COPYCX,ININT(I,2)) ELSE IF (FUNNAM.EQ.'F06HDF') THEN CALL F06HDF(ININT(I,1),COPYCR(1),COPYCX,ININT(I,2),COPYCY, + ININT(I,3)) ELSE IF (FUNNAM.EQ.'F06HTF') THEN CALL F06HTF(ININT(I,1),COPYCR(1),COPYCX,ININT(I,2),COPYCR(2) + ,COPYCY,ININT(I,3)) ELSE WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' STOP END IF MISSED = .NOT. CNDIFV(NCCORX,COPYCX,CPCCRX,TOL) + .OR. .NOT. CNDIFV(NCCORY,COPYCY,CPCCRY,TOL) + .OR. .NOT. CNDIFV(NCCORR,COPYCR,CPCCRR,TOL) IF (MISSED) THEN IF (FIRST) THEN FIRST = .FALSE. WRITE (NOUT,*) ' **** FAIL ****' END IF * Give details of failure here. PR = ' entered with ' IF (NCENTX.GT.0) THEN CALL MATRPC(NCENTX,CENTX,I,1,PR//'X = ',20,80,NOUT) PR = ' and ' END IF IF (NCENTY.GT.0) THEN CALL MATRPC(NCENTY,CENTY,I,1,PR//'Y = ',20,80,NOUT) PR = ' and ' END IF IF (NCREST.GT.0) THEN CALL MATRPC(NCREST,CREST,I,1,PR//'R = ',20,80,NOUT) END IF IF (NCENTY.GT.0) THEN WRITE (NOUT,99999) ' N, INCX, INCY = ', ININT(I,1), + ININT(I,2), ININT(I,3) ELSE WRITE (NOUT,99999) ' N, INCX = ', ININT(I,1), + ININT(I,2) END IF PR = ' returned with ' IF (NCCORX.GT.0) THEN CALL VECPR2(NCCORX,COPYCX,1,PR//'X = ',20,80,NOUT) CALL VECPR2(NCCORX,CPCCRX,1,' (should be) ',20,80, + NOUT) PR = ' and ' END IF IF (NCCORY.GT.0) THEN CALL VECPR2(NCCORY,COPYCY,1,PR//'Y = ',20,80,NOUT) CALL VECPR2(NCCORY,CPCCRY,1,' (should be) ',20,80, + NOUT) PR = ' and ' END IF IF (NCCORR.GT.0) THEN CALL VECPR2(NCCORR,COPYCR,1,PR//'R = ',20,80,NOUT) CALL VECPR2(NCCORR,CPCCRR,1,' (should be) ',20,80, + NOUT) END IF END IF 20 CONTINUE IF (FIRST) THEN WRITE (NOUT,*) ' ---- PASS ----' END IF WRITE (NOUT,*) * RETURN * 99999 FORMAT (1X,A,6I6) END SUBROUTINE CHECK2(FUNNAM,N,NRENTX,RENTX,NCENTY,CENTY,NCREST,CREST, + ININT,NRCORX,RCORX,NCCORY,CCORY,NCCORR,CCORR, + TOL) * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER N, NCCORR, NCCORY, NCENTY, NCREST, NRCORX, + NRENTX CHARACTER*6 FUNNAM * .. Array Arguments .. COMPLEX*16 CCORR(15,6), CCORY(15,6), CENTY(15,6), + CREST(15,6) DOUBLE PRECISION RCORX(15,6), RENTX(15,6) INTEGER ININT(15,6) * .. Local Scalars .. INTEGER I LOGICAL FIRST, MISSED CHARACTER*15 PR * .. Local Arrays .. COMPLEX*16 COPYCR(6), COPYCY(6), CPCCRR(6), CPCCRY(6) DOUBLE PRECISION COPYRX(6), CPRCRX(6) * .. External Functions .. LOGICAL CNDIFV, NODIFV EXTERNAL CNDIFV, NODIFV * .. External Subroutines .. EXTERNAL F06KCF, F06KFF, MATRPC, MATRPR, TOVECC, TOVECR, + VECPR1, VECPR2 * .. Executable Statements .. FIRST = .TRUE. WRITE (NOUT,*) ' Testing routine ', FUNNAM DO 20 I = 1, N CALL TOVECR(RENTX,COPYRX,NRENTX,I) CALL TOVECC(CENTY,COPYCY,NCENTY,I) CALL TOVECC(CREST,COPYCR,NCREST,I) CALL TOVECR(RCORX,CPRCRX,NRCORX,I) CALL TOVECC(CCORY,CPCCRY,NCCORY,I) CALL TOVECC(CCORR,CPCCRR,NCCORR,I) IF (FUNNAM.EQ.'F06KFF') THEN CALL F06KFF(ININT(I,1),COPYRX,ININT(I,2),COPYCY,ININT(I,3)) ELSE IF (FUNNAM.EQ.'F06KCF') THEN CALL F06KCF(ININT(I,1),COPYRX,ININT(I,2),COPYCY,ININT(I,3)) ELSE WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' STOP END IF MISSED = .NOT. NODIFV(NRCORX,COPYRX,CPRCRX,TOL) + .OR. .NOT. CNDIFV(NCCORY,COPYCY,CPCCRY,TOL) + .OR. .NOT. CNDIFV(NCCORR,COPYCR,CPCCRR,TOL) IF (MISSED) THEN IF (FIRST) THEN FIRST = .FALSE. WRITE (NOUT,*) ' **** FAIL ****' END IF * Give details of failure here. PR = ' entered with ' IF (NRENTX.GT.0) THEN CALL MATRPR(NRENTX,RENTX,I,1,PR//'X = ',20,80,NOUT) PR = ' and ' END IF IF (NCENTY.GT.0) THEN CALL MATRPC(NCENTY,CENTY,I,1,PR//'Y = ',20,80,NOUT) PR = ' and ' END IF IF (NCREST.GT.0) THEN CALL MATRPC(NCREST,CREST,I,1,PR//'R = ',20,80,NOUT) END IF IF (NCENTY.GT.0) THEN WRITE (NOUT,99999) ' N, INCX, INCY = ', ININT(I,1), + ININT(I,2), ININT(I,3) ELSE WRITE (NOUT,99999) ' N, INCX = ', ININT(I,1), + ININT(I,2) END IF PR = ' returned with ' IF (NRCORX.GT.0) THEN CALL VECPR1(NRCORX,COPYRX,1,PR//'X = ',20,80,NOUT) CALL VECPR1(NRCORX,CPRCRX,1,' (should be) ',20,80, + NOUT) PR = ' and ' END IF IF (NCCORY.GT.0) THEN CALL VECPR2(NCCORY,COPYCY,1,PR//'Y = ',20,80,NOUT) CALL VECPR2(NCCORY,CPCCRY,1,' (should be) ',20,80, + NOUT) PR = ' and ' END IF IF (NCCORR.GT.0) THEN CALL VECPR2(NCCORR,COPYCR,1,PR//'R = ',20,80,NOUT) CALL VECPR2(NCCORR,CPCCRR,1,' (should be) ',20,80, + NOUT) END IF END IF 20 CONTINUE IF (FIRST) THEN WRITE (NOUT,*) ' ---- PASS ----' END IF WRITE (NOUT,*) * RETURN * 99999 FORMAT (1X,A,6I6) END SUBROUTINE CHECK3(FUNNAM,N,NCENTX,CENTX,NCENTY,CENTY,NRREST,RREST, + ININT,NCCORX,CCORX,NCCORY,CCORY,NRCORR,RCORR, + TOL) * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER N, NCCORX, NCCORY, NCENTX, NCENTY, NRCORR, + NRREST CHARACTER*6 FUNNAM * .. Array Arguments .. COMPLEX*16 CCORX(15,6), CCORY(15,6), CENTX(15,6), + CENTY(15,6) DOUBLE PRECISION RCORR(15,6), RREST(15,6) INTEGER ININT(15,6) * .. Local Scalars .. INTEGER I LOGICAL FIRST, MISSED CHARACTER*15 PR * .. Local Arrays .. COMPLEX*16 COPYCX(6), COPYCY(6), CPCCRX(6), CPCCRY(6) DOUBLE PRECISION COPYRR(6), CPRCRR(6) * .. External Functions .. LOGICAL CNDIFV, NODIFV EXTERNAL CNDIFV, NODIFV * .. External Subroutines .. EXTERNAL F06KDF, F06KJF, F06KPF, MATRPC, MATRPR, TOVECC, + TOVECR, VECPR1, VECPR2 * .. Executable Statements .. FIRST = .TRUE. WRITE (NOUT,*) ' Testing routine ', FUNNAM DO 20 I = 1, N CALL TOVECC(CENTX,COPYCX,NCENTX,I) CALL TOVECC(CENTY,COPYCY,NCENTY,I) CALL TOVECR(RREST,COPYRR,NRREST,I) CALL TOVECC(CCORX,CPCCRX,NCCORX,I) CALL TOVECC(CCORY,CPCCRY,NCCORY,I) CALL TOVECR(RCORR,CPRCRR,NRCORR,I) IF (FUNNAM.EQ.'F06KJF') THEN CALL F06KJF(ININT(I,1),COPYCX,ININT(I,2),COPYRR(1),COPYRR(2) + ) ELSE IF (FUNNAM.EQ.'F06KPF') THEN CALL F06KPF(ININT(I,1),COPYCX,ININT(I,2),COPYCY,ININT(I,3), + COPYRR(1),COPYRR(2)) ELSE IF (FUNNAM.EQ.'F06KDF') THEN CALL F06KDF(ININT(I,1),COPYRR(1),COPYCX,ININT(I,2),COPYCY, + ININT(I,3)) ELSE WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' STOP END IF MISSED = .NOT. CNDIFV(NCCORX,COPYCX,CPCCRX,TOL) + .OR. .NOT. CNDIFV(NCCORY,COPYCY,CPCCRY,TOL) + .OR. .NOT. NODIFV(NRCORR,COPYRR,CPRCRR,TOL) IF (MISSED) THEN IF (FIRST) THEN FIRST = .FALSE. WRITE (NOUT,*) ' **** FAIL ****' END IF * Give details of failure here. PR = ' entered with ' IF (NCENTX.GT.0) THEN CALL MATRPC(NCENTX,CENTX,I,1,PR//'X = ',20,80,NOUT) PR = ' and ' END IF IF (NCENTY.GT.0) THEN CALL MATRPC(NCENTY,CENTY,I,1,PR//'Y = ',20,80,NOUT) PR = ' and ' END IF IF (NRREST.GT.0) THEN CALL MATRPR(NRREST,RREST,I,1,PR//'R = ',20,80,NOUT) END IF IF (NCENTY.GT.0) THEN WRITE (NOUT,99999) ' N, INCX, INCY = ', ININT(I,1), + ININT(I,2), ININT(I,3) ELSE WRITE (NOUT,99999) ' N, INCX = ', ININT(I,1), + ININT(I,2) END IF PR = ' returned with ' IF (NCCORX.GT.0) THEN CALL VECPR2(NCCORX,COPYCX,1,PR//'X = ',20,80,NOUT) CALL VECPR2(NCCORX,CPCCRX,1,' (should be) ',20,80, + NOUT) PR = ' and ' END IF IF (NCCORY.GT.0) THEN CALL VECPR2(NCCORY,COPYCY,1,PR//'Y = ',20,80,NOUT) CALL VECPR2(NCCORY,CPCCRY,1,' (should be) ',20,80, + NOUT) PR = ' and ' END IF IF (NRCORR.GT.0) THEN CALL VECPR1(NRCORR,COPYRR,1,PR//'R = ',20,80,NOUT) CALL VECPR1(NRCORR,CPRCRR,1,' (should be) ',20,80, + NOUT) END IF END IF 20 CONTINUE IF (FIRST) THEN WRITE (NOUT,*) ' ---- PASS ----' END IF WRITE (NOUT,*) * RETURN * 99999 FORMAT (1X,A,6I6) END SUBROUTINE CHECK4(FUNNAM,PIVOT,DIRECT,N,NCENTX,CENTX,ALPHA,BETA, + CORRC,CORRS,ININT,TOL) * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER N, NCENTX CHARACTER*6 FUNNAM * .. Array Arguments .. COMPLEX*16 ALPHA(15), BETA(15), CENTX(15,6), CORRS(15,6) DOUBLE PRECISION CORRC(15,6) INTEGER ININT(15,6) CHARACTER DIRECT(15), PIVOT(15) * .. Local Scalars .. COMPLEX*16 CPYALP INTEGER I LOGICAL FIRST, MISSED * .. Local Arrays .. COMPLEX*16 COPYX(6), CPYCRS(6), S(6) DOUBLE PRECISION C(6), CPYCRC(6) * .. External Functions .. LOGICAL CNDIFF, CNDIFV, NODIFV EXTERNAL CNDIFF, CNDIFV, NODIFV * .. External Subroutines .. EXTERNAL F06HQF, MATRPC, TOVECC, TOVECR, VECPR1, VECPR2 * .. Executable Statements .. FIRST = .TRUE. WRITE (NOUT,*) ' Testing routine ', FUNNAM DO 20 I = 1, N CALL TOVECC(CENTX,COPYX,NCENTX,I) CALL TOVECR(CORRC,CPYCRC,ININT(I,1),I) CALL TOVECC(CORRS,CPYCRS,ININT(I,1),I) CPYALP = ALPHA(I) IF (FUNNAM.EQ.'F06HQF') THEN CALL F06HQF(PIVOT(I),DIRECT(I),ININT(I,1),ALPHA(I),COPYX, + ININT(I,2),C,S) ELSE WRITE (NOUT,*) ' Shouldn''t be here in CHECK4' STOP END IF MISSED = .NOT. NODIFV(ININT(I,1),C,CPYCRC,TOL) + .OR. .NOT. CNDIFV(ININT(I,1),S,CPYCRS,TOL) + .OR. .NOT. CNDIFF(ALPHA(I),BETA(I),TOL) IF (MISSED) THEN IF (FIRST) THEN FIRST = .FALSE. WRITE (NOUT,*) ' **** FAIL ****' END IF * Give details of failure here. CALL MATRPC(NCENTX,CENTX,I,1,' entered with X = ',20,80, + NOUT) WRITE (NOUT,*) ' ALPHA = ', CPYALP WRITE (NOUT,*) ' and N, INCX = ', ININT(I,1), + ININT(I,2) CALL VECPR1(ININT(I,1),C,1,' returned with C = ',20,80,NOUT) CALL VECPR1(ININT(I,1),CPYCRC,1,' (should be)',20,80, + NOUT) CALL VECPR2(ININT(I,1),S,1,' returned with S = ',20,80,NOUT) CALL VECPR2(ININT(I,1),CPYCRS,1,' (should be)',20,80, + NOUT) WRITE (NOUT,*) ' and BETA = ', ALPHA(I) WRITE (NOUT,*) ' (should be) ', BETA(I) END IF 20 CONTINUE IF (FIRST) THEN WRITE (NOUT,*) ' ---- PASS ----' END IF WRITE (NOUT,*) * RETURN END CHARACTER*1 FUNCTION KARCTR(I) * * KARCTR returns a single character from the Fortran 77 * character set as follows. * * I KARCTR I KARCTR I KARCTR I KARCTR I KARCTR * -12 $ * -11 ' * -10 : * -9 . 1 1 11 A 21 K 31 U * -8 , 2 2 12 B 22 L 32 V * -7 ) 3 3 13 C 23 M 33 W * -6 ( 4 4 14 D 24 N 34 X * -5 / 5 5 15 E 25 O 35 Y * -4 * 6 6 16 F 26 P 36 Z * -3 - 7 7 17 G 27 Q OTHER * -2 + 8 8 18 H 28 R * -1 = 9 9 19 I 29 S * 0 0 10 20 J 30 T * * I is not altered by this routine. * * Nag Fortran 77 basic linear algebra routine. * * -- Written on 2-December-1982. Sven. * * .. Scalar Arguments .. INTEGER I * .. Local Scalars .. INTEGER J CHARACTER*49 K * .. Data statements .. DATA K(1:12)/'$'':.,)(/*-+='/ DATA K(13:23)/'0123456789 '/ DATA K(24:36)/'ABCDEFGHIJKLM'/ DATA K(37:49)/'NOPQRSTUVWXYZ'/ * .. Executable Statements .. J = I + 13 IF ((J.LT.1) .OR. (J.GT.49)) J = 23 * KARCTR = K(J:J) RETURN * * End of KARCTR. * END SUBROUTINE SETIO1(NSIG,NCOLS,NOUT,FMT) * * Purpose * ======= * * SETIO1 returns, in the character FMT, a format of the form * * ( 1P nnEnn.nn ) * * where each n is a digit. * * Parameters * ========== * * NSIG - INTEGER. * Before entry, NSIG specifies the number of significant * figures required. the final two digits in the format will be * ( NSIG - 1 ) and the previous two digits will be * ( NSIG + 7 ). If NSIG is not in the range ( 1, 92 ) NSIG is * set to 7, otherwise NSIG is unchanged on exit. * * NCOLS - INTEGER. * Before entry, NCOLS must contain the number of printing * positions per line. The first two digits in the format will * be such that no more than NCOLS print positions per line are * used. For example, if NSIG = 8 and NCOLS = 72 then FMT will * return the format * * ( 1P 4E15.7 ) * * If NCOLS is not positive, or if NCOLS is such that the first * two digits are larger than 99 or are not positive, or if * NCOLS is greater than 132 then NCOLS is set to 72, otherwise * NCOLS is unchanged on exit. * Note that the first print position in the format is blank * and so the format is safe to use when the first print * position is used for carriage control. * * NOUT - INTEGER. * Before entry, NOUT must contain a device number for printing. * Note that this routine does not perform any printing. If NOUT * is negative then NOUT is set to the value returned by the Nag * Library routine X04ABF, otherwise NOUT is unchanged on * exit. * * FMT - CHARACTER*12. * On return FMT will contain the required format in character * positions 1 to 12. * * Nag Fortran 77 basic linear algebra routine. * * -- Written on 1-December-1982. Sven. * * .. Scalar Arguments .. INTEGER NCOLS, NOUT, NSIG CHARACTER*12 FMT * .. Local Scalars .. INTEGER I, J, M, N * .. External Functions .. CHARACTER KARCTR EXTERNAL KARCTR * .. External Subroutines .. EXTERNAL X04ABF * .. Executable Statements .. IF (NOUT.LT.0) CALL X04ABF(0,NOUT) IF ((NSIG.LT.1) .OR. (NSIG.GT.92)) NSIG = 7 IF ((NCOLS.LT.1) .OR. (NCOLS.GT.132)) NCOLS = 72 * FMT = '(1P E . )' I = NSIG + 7 M = I/10 N = I - 10*M IF (M.EQ.0) M = 10 * FMT(7:7) = KARCTR(M) FMT(8:8) = KARCTR(N) * J = NSIG - 1 M = J/10 N = J - 10*M IF (M.EQ.0) M = 10 * FMT(10:10) = KARCTR(M) FMT(11:11) = KARCTR(N) * J = NCOLS/I IF ((J.LT.1) .OR. (J.GT.99)) THEN NCOLS = 72 J = NCOLS/I IF (J.LT.1) J = 1 END IF M = J/10 N = J - 10*M IF (M.EQ.0) M = 10 * FMT(4:4) = KARCTR(M) FMT(5:5) = KARCTR(N) * RETURN * * End of SETIO1. * END * * SUBROUTINE SETIO2(NSIG,NCOLS,NOUT,FMT) * * Purpose * ======= * * SETIO2 returns, in the character FMT, a format of the form * * ( nn( 1P Enn.nn, 1A,, 1P Enn.nn ) ) * * where each n is a digit. * * Parameters * ========== * * NSIG - INTEGER. * Before entry, NSIG specifies the number of significant * figures required. The two digits following each decimal point * will be ( NSIG - 1 ) and the previous two digits will be * ( NSIG + 7 ) for the first value and ( NSIG + 6 ) for the * second value. * If NSIG is not in the range ( 1, 92 ) NSIG is set to 7, * otherwise NSIG is unchanged on exit. * * NCOLS - INTEGER. * Before entry, NCOLS must contain the number of printing * positions per line. The first two digits in the format will * be such that no more than NCOLS print positions per line are * used. For example, if NSIG = 4 and NCOLS = 72 then FMT will * return the format * * ( 3( 1P E11.3, 1A,, 1P E10.3 ) ) * * If NCOLS is not positive or if NCOLS is such that the first * two digits are larger than 99 or are not positive, or if * NCOLS is greater than 132 then NCOLS is set to 72, otherwise * NCOLS is unchanged on exit. * Note that the first print position in the format is blank * and so the format is safe to use when the first print * position is used for carriage control. * * NOUT - INTEGER. * Before entry, NOUT must contain a device number for printing. * Note that this routine does not perform any printing. If NOUT * is negative then NOUT is set to the value returned by the Nag * Library routine X04ABF, otherwise NOUT is unchanged on * exit. * * FMT - CHARACTER*27. * On return FMT will contain the required format in character * positions 1 to 27. * * Nag Fortran 77 basic linear algebra routine. * * -- Written on 28-April-1983. Sven. * * .. Scalar Arguments .. INTEGER NCOLS, NOUT, NSIG CHARACTER*27 FMT * .. Local Scalars .. INTEGER I, J, M, N * .. External Functions .. CHARACTER KARCTR EXTERNAL KARCTR * .. External Subroutines .. EXTERNAL X04ABF * .. Executable Statements .. IF (NOUT.LT.0) CALL X04ABF(0,NOUT) IF ((NSIG.LT.1) .OR. (NSIG.GT.92)) NSIG = 7 IF ((NCOLS.LT.1) .OR. (NCOLS.GT.132)) NCOLS = 72 * FMT = '( (1PE . ,1A,,1PE . ))' I = NSIG + 7 M = I/10 N = I - 10*M IF (M.EQ.0) M = 10 * FMT(8:8) = KARCTR(M) FMT(9:9) = KARCTR(N) * J = I - 1 M = J/10 N = J - 10*M IF (M.EQ.0) M = 10 * FMT(21:21) = KARCTR(M) FMT(22:22) = KARCTR(N) * J = NSIG - 1 M = J/10 N = J - 10*M IF (M.EQ.0) M = 10 * FMT(11:11) = KARCTR(M) FMT(24:24) = FMT(11:11) FMT(12:12) = KARCTR(N) FMT(25:25) = FMT(12:12) * J = NCOLS/(2*I) IF ((J.LT.1) .OR. (J.GT.99)) THEN NCOLS = 72 J = NCOLS/(2*I) IF (J.LT.1) J = 1 END IF M = J/10 N = J - 10*M IF (M.EQ.0) M = 10 * FMT(2:2) = KARCTR(M) FMT(3:3) = KARCTR(N) * RETURN * * End of SETIO2. * END SUBROUTINE VECPR1(N,X,INCX,TITLE,NSIG,NCOLS,NOUT) * * Purpose * ======= * * VECPR1 prints out the n element vector x, using an E format on * device NOUT. Each element is printed to NSIG significant figures. * A heading may be printed before the vector. * * Parameters * ========== * * N - INTEGER. * On entry, N specifies the number of elements of x to be * printed. If N is not positive then an immediate return is * made. * Unchanged on exit. * * X - REAL array of DIMENSION at least * ( max( 1, 1 + ( n - 1 )*abs( INCX ) ) ). * Before entry, the incremented array X must contain the vector * to be printed. * If INCX is positive then the elements X( 1 ), X( 1 + INCX ), * ..., X( 1 + ( N - 1 )*INCX ) are printed. * If INCX is negative then the elements * X( 1 - ( N - 1 )*INCX ),..., X( 1 - INCX ), X( 1 ) are * printed. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for printing. If INCX * is zero then an immediate return is made. * Unchanged on exit. * * TITLE - CHARACTER of length at least 1, but only one record. * On entry, TITLE specifies a heading to be printed before * printing the vector x. Unless TITLE is blank, TITLE is * printed using the format * * FORMAT( 1X, A ) * * and a blank line is printed following the heading. * Any trailing blanks in TITLE are not printed. * Unchanged on exit. * * NSIG - INTEGER. * On entry, NSIG specifies the number of significant figures to * which the elements of x are printed. The field width for each * element of x will be ( NSIG + 7 ). If NSIG is outside the * range ( 1, 92 ) then the value 7 is used in place of NSIG. * Unchanged on exit. * * NCOLS - INTEGER. * On entry, NCOLS specifies the maximum number of printing * positions per line. If NCOLS is not large enough to allow at * least one element per line or if NCOLS is greater than 132 * then the value 72 is used in place of NCOLS. * Unchanged on exit. * * NOUT - INTEGER. * On entry, NOUT specifies the device number for printing. If * NOUT is negative then the value returned by the Nag Library * routine X04ABF is used in place of NOUT. * Unchanged on exit. * * Further comments * ================ * * To print the elements of the 20 element vector x, to 4 significant * figures on unit 6, with no more than 60 print positions per line * and the heading 'Vector x', VECPR1 may be called as * * CALL VECPR1( 20, X, 1, 'Vector x', 4, 60, 6 ) * * To get the default values for NSIG, NCOLS and NOUT, VECPR1 may be * called as * * CALL VECPR1( 20, X, 1, 'Vector x', -1, -1, -1 ) * * Nag Fortran 77 basic linear algebra routine. * * -- Written on 6-December-1982. Sven. * * .. Scalar Arguments .. INTEGER INCX, N, NCOLS, NOUT, NSIG CHARACTER*(*) TITLE * .. Array Arguments .. DOUBLE PRECISION X(*) * .. Local Scalars .. INTEGER I, IOUT, J, K, LENT, NC, NS CHARACTER*12 FMT CHARACTER*133 REC * .. External Functions .. INTEGER BAZ EXTERNAL BAZ * .. External Subroutines .. EXTERNAL SETIO1, X04BAF * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. IF ((N.LT.1) .OR. (INCX.EQ.0)) RETURN * IOUT = NOUT NS = NSIG NC = NCOLS * * SETIO1 checks NOUT, NSIG and NCOLS and returns the format. * K gives the number of elements to be printed per line. * CALL SETIO1(NS,NC,IOUT,FMT) K = NC/(NS+7) * * Print the heading. * LENT = BAZ(TITLE) IF (LENT.GT.0) THEN WRITE (REC,99999) TITLE(1:LENT) CALL X04BAF(IOUT,REC) END IF * * Print the vector x. * IF (INCX.GT.0) THEN DO 20 J = 1, 1 + (N-1)*INCX, K*INCX WRITE (REC,FMT) (X(I),I=J,MIN(J+(K-1)*INCX,1+(N-1)*INCX) + ,INCX) CALL X04BAF(IOUT,REC) 20 CONTINUE ELSE DO 40 J = 1 - (N-1)*INCX, 1, K*INCX WRITE (REC,FMT) (X(I),I=J,MAX(J+(K-1)*INCX,1),INCX) CALL X04BAF(IOUT,REC) 40 CONTINUE END IF * RETURN * * * End of VECPR1. * 99999 FORMAT (1X,A) END SUBROUTINE VECPR2(N,X,INCX,TITLE,NSIG,NCOLS,NOUT) * * Purpose * ======= * * VECPR2 prints out the n element vector x, using an E format on * device NOUT. Each element is printed to NSIG significant figures. * A heading may be printed before the vector. * * Parameters * ========== * * N - INTEGER. * On entry, N specifies the number of elements of x to be * printed. If N is not positive then an immediate return is * made. * Unchanged on exit. * * X - COMPLEX array of DIMENSION at least * ( max( 1, 1 + ( n - 1 )*abs( INCX ) ) ). * Before entry, the incremented array X must contain the vector * to be printed. * If INCX is positive then the elements X( 1 ), X( 1 + INCX ), * ..., X( 1 + ( N - 1 )*INCX ) are printed. * If INCX is negative then the elements * X( 1 - ( N - 1 )*INCX ),..., X( 1 - INCX ), X( 1 ) are * printed. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for printing. If INCX * is zero then an immediate return is made. * Unchanged on exit. * * TITLE - CHARACTER of length at least 1, but only one record. * On entry, TITLE specifies a heading to be printed before * printing the vector x. Unless TITLE is blank, TITLE is * printed using the format * * FORMAT( 1X, A ) * * and a blank line is printed following the heading. * Any trailing blanks in TITLE are not printed. * Unchanged on exit. * * NSIG - INTEGER. * On entry, NSIG specifies the number of significant figures to * which the elements of x are printed. The field width for each * element of x will be 2*( NSIG + 7 ). A comma separates the * real and imaginary parts. If NSIG is outside the range * ( 1, 92 ) then the value 7 is used in place of NSIG. * Unchanged on exit. * * NCOLS - INTEGER. * On entry, NCOLS specifies the maximum number of printing * positions per line. If NCOLS is not large enough to allow at * least one element per line, or if NCOLS is greater than 132 * then the value 72 is used in place of NCOLS. * Unchanged on exit. * * NOUT - INTEGER. * On entry, NOUT specifies the device number for printing. If * NOUT is negative then the value returned by the Nag Library * routine X04ABF is used in place of NOUT. * Unchanged on exit. * * Further comments * ================ * * To print the elements of the 20 element vector x, to 4 significant * figures on unit 6, with no more than 60 print positions per line * and the heading 'Vector x', then VECPR2 may be called as * * CALL VECPR2( 20, X, 1, 'Vector x', 4, 60, 6 ) * * To get the default values for NSIG, NCOLS and NOUT, VECPR2 may be * called as * * CALL VECPR2( 20, X, 1, 'Vector x', -1, -1, -1 ) * * Nag Fortran 77 basic linear algebra routine. * * -- Written on 28-April-1983. Sven. * * .. Scalar Arguments .. INTEGER INCX, N, NCOLS, NOUT, NSIG CHARACTER*(*) TITLE * .. Array Arguments .. COMPLEX*16 X(*) * .. Local Scalars .. INTEGER I, IOUT, J, K, LENT, NC, NS CHARACTER*27 FMT CHARACTER*133 REC * .. External Functions .. INTEGER BAZ EXTERNAL BAZ * .. External Subroutines .. EXTERNAL SETIO2, X04BAF * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * IF ((N.LT.1) .OR. (INCX.EQ.0)) RETURN * IOUT = NOUT NS = NSIG NC = NCOLS * * SETIO2 checks NOUT, NSIG and NCOLS and returns the format. * K gives the number of elements to be printed per line. * CALL SETIO2(NS,NC,IOUT,FMT) K = NC/(2*(NS+7)) * * Print the heading. * LENT = BAZ(TITLE) IF (LENT.GT.0) THEN WRITE (REC,99999) TITLE(1:LENT) CALL X04BAF(IOUT,REC) END IF * * Print the vector. * IF (INCX.GT.0) THEN DO 20 J = 1, 1 + (N-1)*INCX, K*INCX WRITE (REC,FMT) (X(I),I=J,MIN(J+(K-1)*INCX,1+(N-1)*INCX) + ,INCX) CALL X04BAF(IOUT,REC) 20 CONTINUE ELSE DO 40 J = 1 - (N-1)*INCX, 1, K*INCX WRITE (REC,FMT) (X(I),I=J,MAX(J+(K-1)*INCX,1),INCX) CALL X04BAF(IOUT,REC) 40 CONTINUE END IF * RETURN * * * End of VECPR2. * 99999 FORMAT (1X,A) END INTEGER FUNCTION BAZ(C) * * BAZ returns, via the function name, the length of the * character C when trailing blanks are ignored. * * For example if C is the character of length 6 given by * * C = 'ABC ' * * then BAZ is returned as 3. * * If C contains only blanks then BAZ is returned as zero. * * -- Written on 8-October-1982. Sven. * Fortran 77 routine. * * .. Scalar Arguments .. CHARACTER*(*) C * .. Local Scalars .. INTEGER I * .. Intrinsic Functions .. INTRINSIC LEN * .. Executable Statements .. * DO 20 I = LEN(C), 1, -1 IF (C(I:I).NE.' ') GO TO 40 20 CONTINUE 40 BAZ = I RETURN * * End of BAZ. * END LOGICAL FUNCTION NODIFF(SCOMP,STRUE,TOL) * Returns .TRUE. if there is no difference between SCOMP and STRUE, * to tolerance TOL. * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) * .. Scalar Arguments .. DOUBLE PRECISION SCOMP, STRUE, TOL * .. Local Scalars .. DOUBLE PRECISION DIF, SC, ST * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Executable Statements .. IF (ABS(SCOMP).LT.TOL) THEN SC = ZERO ELSE SC = SCOMP END IF IF (ABS(STRUE).LT.TOL) THEN ST = ZERO ELSE ST = STRUE END IF DIF = ABS(SC-ST) IF (SC.NE.ZERO .AND. ST.NE.ZERO) DIF = DIF/MAX(ABS(SC),ABS(ST)) NODIFF = DIF .LE. TOL RETURN END * LOGICAL FUNCTION CNDIFF(SCOMP,STRUE,TOL) * Returns .TRUE. if there is no difference between SCOMP and STRUE, * to tolerance TOL. * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D+0) * .. Scalar Arguments .. COMPLEX*16 SCOMP, STRUE DOUBLE PRECISION TOL * .. Local Scalars .. COMPLEX*16 SC DOUBLE PRECISION ABSDIF, ABSMAX, ISC, RSC * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, MAX * .. Executable Statements .. RSC = DBLE(SCOMP) ISC = DIMAG(SCOMP) IF (ABS(RSC).LE.TOL .AND. DBLE(STRUE).EQ.ZERO) RSC = ZERO IF (ABS(ISC).LE.TOL .AND. DIMAG(STRUE).EQ.ZERO) ISC = ZERO SC = DCMPLX(RSC,ISC) ABSDIF = ABS(SC-STRUE) * ABSMAX = MAX(ABS(SC),ABS(STRUE)) * CNDIFF = ABSDIF .LE. TOL*ABSMAX * Replace the two lines above by the two lines below, to avoid * possible overflow in ABS when SC or STRUE is very large. ABSMAX = MAX(ABS(SC*TOL),ABS(STRUE*TOL)) CNDIFF = ABSDIF .LE. ABSMAX RETURN END * LOGICAL FUNCTION NODIFV(LEN,SCOMP,STRUE,TOL) * Returns .TRUE. if there is no difference between arrays SCOMP and * STRUE, to tolerance TOL. Differences are checked componentwise. * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER LEN * .. Array Arguments .. DOUBLE PRECISION SCOMP(*), STRUE(*) * .. Local Scalars .. INTEGER I * .. External Functions .. LOGICAL NODIFF EXTERNAL NODIFF * .. Executable Statements .. NODIFV = .TRUE. DO 20 I = 1, LEN NODIFV = NODIFV .AND. NODIFF(SCOMP(I),STRUE(I),TOL) 20 CONTINUE RETURN END * LOGICAL FUNCTION CNDIFV(LEN,SCOMP,STRUE,TOL) * Returns .TRUE. if there is no difference between arrays SCOMP and * STRUE, to tolerance TOL. Differences are checked componentwise, * and real and imaginary parts are treated separately. * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER LEN * .. Array Arguments .. COMPLEX*16 SCOMP(*), STRUE(*) * .. Local Scalars .. INTEGER I * .. External Functions .. LOGICAL CNDIFF EXTERNAL CNDIFF * .. Executable Statements .. CNDIFV = .TRUE. DO 20 I = 1, LEN CNDIFV = CNDIFV .AND. CNDIFF(SCOMP(I),STRUE(I),TOL) 20 CONTINUE RETURN END