C ALGORITHM 801, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 26, NO. 1, March, 2000, P. 176--200. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Doc/ # Doc/README # Fortran90/ # Fortran90/Dp/ # Fortran90/Dp/Drivers/ # Fortran90/Dp/Drivers/INPUT.DAT # Fortran90/Dp/Drivers/OUTPUT.DAT # Fortran90/Dp/Drivers/main_template.f90 # Fortran90/Dp/Drivers/test_install.f90 # Fortran90/Dp/Src/ # Fortran90/Dp/Src/lapack_plp.f # Fortran90/Dp/Src/polsys_plp.f90 # This archive created: Mon Sep 4 12:18:17 2000 export PATH; PATH=/bin:$PATH if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test -f 'README' then echo shar: will not over-write existing file "'README'" else cat << SHAR_EOF > 'README' POLSYS_PLP POLSYS_PLP is Fortran 90 code for solving N complex coefficient polynomial systems of equations in N unknowns by a probability-one, globally convergent homotopy method. The package consists of 2 modules: GLOBAL_PLP contains the derived data types which define the polynomial system, the system partition, and the start system of the homotopy; the module POLSYS contains the actual solver POLSYS_PLP and its internal routines, and the routines responsible for root counting, BEZOUT_PLP and SINGSYS_PLP. POLSYS_PLP uses the HOMPACK90 modules HOMOTOPY, HOMPACK90_GLOBAL, and REAL_PRECISION, the HOMPACK90 path tracking routine STEPNX, and numerous BLAS and LAPACK routines. The physical organization into files is as follows: The file polsys_plp.f90 contains (in order) REAL_PRECISION, GLOBAL_PLP, POLSYS, HOMPACK90_GLOBAL, HOMOTOPY, and STEPNX; the file lapack_plp.f contains all the necessary BLAS and LAPACK routines. A sample calling program MAIN_TEMPLATE and a template for a hand-crafted function/Jacobian evaluation program TARGET_SYSTEM_USER are contained in the file main_template.f90. MAIN_TEMPLATE reads the data file INPUT.DAT and writes the solutions to the file OUTPUT.DAT. The file test_install.f90 contains a main program TEST_INSTALL to verify the installation. It reads INPUT.DAT, solves a problem defined there, compares the computed results to known answers, and prints a message indicating whether the installation was apparently successful. To test the package, compile polsys_plp.f90 (as free form Fortran 90 files) and compile lapack_plp.f (as fixed form Fortran 90 files). Then compile main_template.f90 and link to the object files from the two compiles above. Do the same for test_install.f90. TEST_INSTALL provides a simple test of the installation. MAIN_TEMPLATE produces detailed output in the file OUTPUT.DAT, which, with an understanding of how POLSYS_PLP works, can be compared to the file OUTPUT.DAT in the package. The modules and external subroutines in polsys_plp.f90 and lapack_plp.f can be stored in module and object libraries and need not be recompiled. The subroutine TARGET_SYSTEM_USER defining the polynomial system and its Jacobian matrix, or a dummy subroutine, must be supplied on every call to POLSYS_PLP. However, if the user does not wish to change TARGET_SYSTEM_USER, its object code can be stored in the aforementioned object library. ------------------------------------------------------------------------------- Inquiries should be directed to Layne T. Watson, Department of Computer Science, VPI & SU, Blacksburg, VA 24061-0106; (540) 231-7540; ltw@vt.edu. SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Fortran90' then mkdir 'Fortran90' fi cd 'Fortran90' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test ! -d 'Drivers' then mkdir 'Drivers' fi cd 'Drivers' if test -f 'INPUT.DAT' then echo shar: will not over-write existing file "'INPUT.DAT'" else cat << SHAR_EOF > 'INPUT.DAT' &PROBLEM NEW_PROBLEM=.TRUE. TITLE='TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS.' TRACKTOL = 1.0D-4 FINALTOL = 1.0D-14 SINGTOL = 0.0 SSPAR(5) = 1.0D0 NUMRR = 1 N = 2 NUM_TERMS(1) = 6 COEF(1,1) = (-9.80D-04,0.0) DEG(1,1,1) = 2 COEF(1,2) = ( 9.78D+05,0.0) DEG(1,2,2) = 2 COEF(1,3) = (-9.80D+00,0.0) DEG(1,3,1) = 1 DEG(1,3,2) = 1 COEF(1,4) = (-2.35D+02,0.0) DEG(1,4,1) = 1 COEF(1,5) = ( 8.89D+04,0.0) DEG(1,5,2) = 1 COEF(1,6) = (-1.00D+00,0.0) NUM_TERMS(2) = 6 COEF(2,1) = (-1.00D-02,0.0) DEG(2,1,1) = 2 COEF(2,2) = (-9.84D-01,0.0) DEG(2,2,2) = 2 COEF(2,3) = (-2.97D+01,0.0) DEG(2,3,1) = 1 DEG(2,3,2) = 1 COEF(2,4) = ( 9.87D-03,0.0) DEG(2,4,1) = 1 COEF(2,5) = (-1.24D-01,0.0) DEG(2,5,2) = 1 COEF(2,6) = (-2.50D-01,0.0) / &SYSPARTITION ROOT_COUNT_ONLY = .FALSE. P(1) = '{{x1,x2}}' P(2) = '{{x1,x2}}' NUM_SETS(1) = 1 NUM_INDICES(1,1) = 2 INDEX(1,1,1) = 1 INDEX(1,1,2) = 2 NUM_SETS(2) = 1 NUM_INDICES(2,1) = 2 INDEX(2,1,1) = 1 INDEX(2,1,2) = 2 / &PROBLEM NEW_PROBLEM = .TRUE. TITLE='PB803, 48 FINITE SOLUTIONS, TOTAL DEGREE 256.' TRACKTOL = 1.0D-06 FINALTOL = 1.0D-12 SINGTOL = 0.0 SSPAR(5) = 1.0D0 NUMRR = 1 N = 8 DEG=27000*0 NUM_TERMS(1) = 17 DEG( 1, 1, 1) = 1 DEG( 1, 1, 3) = 1 COEF( 1, 1) = (-0.290965281036386D-01, 0.D0) DEG( 1, 2, 1) = 1 DEG( 1, 2, 4) = 1 COEF( 1, 2) = (0.123862737830566D+00, 0.D0) DEG( 1, 3, 2) = 1 DEG( 1, 3, 3) = 1 COEF( 1, 3) = (0.215085387051146D-01, 0.D0) DEG( 1, 4, 2) = 1 DEG( 1, 4, 4) = 1 COEF( 1, 4) = (0.167560227205193D+00, 0.D0) DEG( 1, 5, 5) = 1 DEG( 1, 5, 7) = 1 COEF( 1, 5) = (0.000000000000000D+00, 0.D0) DEG( 1, 6, 5) = 1 DEG( 1, 6, 8) = 1 COEF( 1, 6) = (-0.700449587631292D-01, 0.D0) DEG( 1, 7, 6) = 1 DEG( 1, 7, 7) = 1 COEF( 1, 7) = (-0.270632938682637D+00, 0.D0) DEG( 1, 8, 6) = 1 DEG( 1, 8, 8) = 1 COEF( 1, 8) = (0.000000000000000D+00, 0.D0) DEG( 1, 9, 1) = 1 COEF( 1, 9) = (-0.615842911676544D+00, 0.D0) DEG( 1, 10, 2) = 1 COEF( 1, 10) = (0.455239231804051D+00, 0.D0) DEG( 1, 11, 3) = 1 COEF( 1, 11) = (0.130935803481163D+00, 0.D0) DEG( 1, 12, 4) = 1 COEF( 1, 12) = (-0.129409522551260D+00, 0.D0) DEG( 1, 13, 5) = 1 COEF( 1, 13) = (0.418258151868904D+00, 0.D0) DEG( 1, 14, 6) = 1 COEF( 1, 14) = (-0.541265877365274D+00, 0.D0) DEG( 1, 15, 7) = 1 COEF( 1, 15) = (0.000000000000000D+00, 0.D0) DEG( 1, 16, 8) = 1 COEF( 1, 16) = (0.150925910357667D+00, 0.D0) COEF( 1, 17) = (-0.238536449761034D-01, 0.D0) NUM_TERMS(2)=17 DEG( 2, 1, 1) = 1 DEG( 2, 1, 3) = 1 COEF( 2, 1) = (0.340782576514583D-01, 0.D0) DEG( 2, 2, 1) = 1 DEG( 2, 2, 4) = 1 COEF( 2, 2) = (-0.156062186852569D+00, 0.D0) DEG( 2, 3, 2) = 1 DEG( 2, 3, 3) = 1 COEF( 2, 3) = (-0.270999143496647D-01, 0.D0) DEG( 2, 4, 2) = 1 DEG( 2, 4, 4) = 1 COEF( 2, 4) = (-0.196248864280182D+00, 0.D0) DEG( 2, 5, 5) = 1 DEG( 2, 5, 7) = 1 COEF( 2, 5) = (0.220738619037920D+00, 0.D0) DEG( 2, 6, 5) = 1 DEG( 2, 6, 8) = 1 COEF( 2, 6) = (0.000000000000000D+00, 0.D0) DEG( 2, 7, 6) = 1 DEG( 2, 7, 7) = 1 COEF( 2, 7) = (0.000000000000000D+00, 0.D0) DEG( 2, 8, 6) = 1 DEG( 2, 8, 8) = 1 COEF( 2, 8) = (-0.852868531952443D+00, 0.D0) DEG( 2, 9, 1) = 1 COEF( 2, 9) = (0.721283767677873D+00, 0.D0) DEG( 2, 10, 2) = 1 COEF( 2, 10) = (-0.573583559517377D+00, 0.D0) DEG( 2, 11, 3) = 1 COEF( 2, 11) = (0.631988450754851D-01, 0.D0) DEG( 2, 12, 4) = 1 COEF( 2, 12) = (0.000000000000000D+00, 0.D0) DEG( 2, 13, 5) = 1 COEF( 2, 13) = (-0.145259531732747D+00, 0.D0) DEG( 2, 14, 6) = 1 COEF( 2, 14) = (0.000000000000000D+00, 0.D0) DEG( 2, 15, 7) = 1 COEF( 2, 15) = (-0.475625621282099D+00, 0.D0) DEG( 2, 16, 8) = 1 COEF( 2, 16) = (0.000000000000000D+00, 0.D0) COEF( 2, 17) = (0.191169832725054D-01, 0.D0) NUM_TERMS(3)=17 DEG( 3, 1, 1) = 1 DEG( 3, 1, 3) = 1 COEF( 3, 1) = (-0.602977987152187D+00, 0.D0) DEG( 3, 2, 1) = 1 DEG( 3, 2, 4) = 1 COEF( 3, 2) = (-0.131668276721907D+00, 0.D0) DEG( 3, 3, 2) = 1 DEG( 3, 3, 3) = 1 COEF( 3, 3) = (-0.758247385552503D+00, 0.D0) DEG( 3, 4, 2) = 1 DEG( 3, 4, 4) = 1 COEF( 3, 4) = (0.104706028642251D+00, 0.D0) DEG( 3, 5, 5) = 1 DEG( 3, 5, 7) = 1 COEF( 3, 5) = (-0.551846547594801D-01, 0.D0) DEG( 3, 6, 5) = 1 DEG( 3, 6, 8) = 1 COEF( 3, 6) = (0.123100969126526D+00, 0.D0) DEG( 3, 7, 6) = 1 DEG( 3, 7, 7) = 1 COEF( 3, 7) = (0.318608752805224D-01, 0.D0) DEG( 3, 8, 6) = 1 DEG( 3, 8, 8) = 1 COEF( 3, 8) = (0.213217132988111D+00, 0.D0) DEG( 3, 9, 1) = 1 COEF( 3, 9) = (-0.214660295785905D-01, 0.D0) DEG( 3, 10, 2) = 1 COEF( 3, 10) = (-0.601805216517440D+00, 0.D0) DEG( 3, 11, 3) = 1 COEF( 3, 11) = (0.000000000000000D+00, 0.D0) DEG( 3, 12, 4) = 1 COEF( 3, 12) = (0.244181586600211D+00, 0.D0) DEG( 3, 13, 5) = 1 COEF( 3, 13) = (0.363148829331866D-01, 0.D0) DEG( 3, 14, 6) = 1 COEF( 3, 14) = (-0.209664074370650D-01, 0.D0) DEG( 3, 15, 7) = 1 COEF( 3, 15) = (-0.713438431923148D+00, 0.D0) DEG( 3, 16, 8) = 1 COEF( 3, 16) = (0.615504845632630D+00, 0.D0) COEF( 3, 17) = (0.547700898171009D+00, 0.D0) NUM_TERMS(4)=17 DEG( 4, 1, 1) = 1 DEG( 4, 1, 3) = 1 COEF( 4, 1) = (0.478568869541663D+00, 0.D0) DEG( 4, 2, 1) = 1 DEG( 4, 2, 4) = 1 COEF( 4, 2) = (0.112420351802601D+00, 0.D0) DEG( 4, 3, 2) = 1 DEG( 4, 3, 3) = 1 COEF( 4, 3) = (0.647403003665440D+00, 0.D0) DEG( 4, 4, 2) = 1 DEG( 4, 4, 4) = 1 COEF( 4, 4) = (-0.831026120840329D-01, 0.D0) DEG( 4, 5, 5) = 1 DEG( 4, 5, 7) = 1 COEF( 4, 5) = (0.390625000000000D-01, 0.D0) DEG( 4, 6, 5) = 1 DEG( 4, 6, 8) = 1 COEF( 4, 6) = (0.175112396907823D-01, 0.D0) DEG( 4, 7, 6) = 1 DEG( 4, 7, 7) = 1 COEF( 4, 7) = (0.676582346706593D-01, 0.D0) DEG( 4, 8, 6) = 1 DEG( 4, 8, 8) = 1 COEF( 4, 8) = (-0.101101189493172D-01, 0.D0) DEG( 4, 9, 1) = 1 COEF( 4, 9) = (0.196623270912993D-03, 0.D0) DEG( 4, 10, 2) = 1 COEF( 4, 10) = (0.500438376735814D+00, 0.D0) DEG( 4, 11, 3) = 1 COEF( 4, 11) = (-0.500000000000000D+00, 0.D0) DEG( 4, 12, 4) = 1 COEF( 4, 12) = (0.505897096673464D+00, 0.D0) DEG( 4, 13, 5) = 1 COEF( 4, 13) = (-0.264395379672260D-01, 0.D0) DEG( 4, 14, 6) = 1 COEF( 4, 14) = (0.195686833484385D+00, 0.D0) DEG( 4, 15, 7) = 1 COEF( 4, 15) = (0.195312500000000D+00, 0.D0) DEG( 4, 16, 8) = 1 COEF( 4, 16) = (0.226388865536500D+00, 0.D0) COEF( 4, 17) = (-0.339187450014371D+00, 0.D0) NUM_TERMS(5)=3 DEG( 5, 1, 1) = 2 COEF( 5, 1) = (0.100000000000000D+01, 0.D0) DEG( 5, 2, 2) = 2 COEF( 5, 2) = (0.100000000000000D+01, 0.D0) COEF( 5, 3) = (-0.100000000000000D+01, 0.D0) NUM_TERMS(6)=3 DEG( 6, 1, 3) = 2 COEF( 6, 1) = (0.100000000000000D+01, 0.D0) DEG( 6, 2, 4) = 2 COEF( 6, 2) = (0.100000000000000D+01, 0.D0) COEF( 6, 3) = (-0.100000000000000D+01, 0.D0) NUM_TERMS(7)=3 DEG( 7, 1, 5) = 2 COEF( 7, 1) = (0.100000000000000D+01, 0.D0) DEG( 7, 2, 6) = 2 COEF( 7, 2) = (0.100000000000000D+01, 0.D0) COEF( 7, 3) = (-0.100000000000000D+01, 0.D0) NUM_TERMS(8)=3 DEG( 8, 1, 7) = 2 COEF( 8, 1) = (0.100000000000000D+01, 0.D0) DEG( 8, 2, 8) = 2 COEF( 8, 2) = (0.100000000000000D+01, 0.D0) COEF( 8, 3) = (-0.100000000000000D+01, 0.D0) / &SYSPARTITION ROOT_COUNT_ONLY = .TRUE. P(1) = '{{1,2,3,4,5,6,7,8}}' P(2) = '{{1,2,3,4,5,6,7,8}}' P(3) = '{{1,2,3,4,5,6,7,8}}' P(4) = '{{1,2,3,4,5,6,7,8}}' P(5) = '{{1,2,3,4,5,6,7,8}}' P(6) = '{{1,2,3,4,5,6,7,8}}' P(7) = '{{1,2,3,4,5,6,7,8}}' P(8) = '{{1,2,3,4,5,6,7,8}}' NUM_SETS(1) = 1 NUM_INDICES(1,1) = 8 INDEX(1,1,1) = 1 INDEX(1,1,2) = 2 INDEX(1,1,3) = 3 INDEX(1,1,4) = 4 INDEX(1,1,5) = 5 INDEX(1,1,6) = 6 INDEX(1,1,7) = 7 INDEX(1,1,8) = 8 NUM_SETS(2) = 1 NUM_INDICES(2,1) = 8 INDEX(2,1,1) = 1 INDEX(2,1,2) = 2 INDEX(2,1,3) = 3 INDEX(2,1,4) = 4 INDEX(2,1,5) = 5 INDEX(2,1,6) = 6 INDEX(2,1,7) = 7 INDEX(2,1,8) = 8 NUM_SETS(3) = 1 NUM_INDICES(3,1) = 8 INDEX(3,1,1) = 1 INDEX(3,1,2) = 2 INDEX(3,1,3) = 3 INDEX(3,1,4) = 4 INDEX(3,1,5) = 5 INDEX(3,1,6) = 6 INDEX(3,1,7) = 7 INDEX(3,1,8) = 8 NUM_SETS(4) = 1 NUM_INDICES(4,1) = 8 INDEX(4,1,1) = 1 INDEX(4,1,2) = 2 INDEX(4,1,3) = 3 INDEX(4,1,4) = 4 INDEX(4,1,5) = 5 INDEX(4,1,6) = 6 INDEX(4,1,7) = 7 INDEX(4,1,8) = 8 NUM_SETS(5) = 1 NUM_INDICES(5,1) = 8 INDEX(5,1,1) = 1 INDEX(5,1,2) = 2 INDEX(5,1,3) = 3 INDEX(5,1,4) = 4 INDEX(5,1,5) = 5 INDEX(5,1,6) = 6 INDEX(5,1,7) = 7 INDEX(5,1,8) = 8 NUM_SETS(6) = 1 NUM_INDICES(6,1) = 8 INDEX(6,1,1) = 1 INDEX(6,1,2) = 2 INDEX(6,1,3) = 3 INDEX(6,1,4) = 4 INDEX(6,1,5) = 5 INDEX(6,1,6) = 6 INDEX(6,1,7) = 7 INDEX(6,1,8) = 8 NUM_SETS(7) = 1 NUM_INDICES(7,1) = 8 INDEX(7,1,1) = 1 INDEX(7,1,2) = 2 INDEX(7,1,3) = 3 INDEX(7,1,4) = 4 INDEX(7,1,5) = 5 INDEX(7,1,6) = 6 INDEX(7,1,7) = 7 INDEX(7,1,8) = 8 NUM_SETS(8) = 1 NUM_INDICES(8,1) = 8 INDEX(8,1,1) = 1 INDEX(8,1,2) = 2 INDEX(8,1,3) = 3 INDEX(8,1,4) = 4 INDEX(8,1,5) = 5 INDEX(8,1,6) = 6 INDEX(8,1,7) = 7 INDEX(8,1,8) = 8 / &PROBLEM NEW_PROBLEM = .FALSE. / &SYSPARTITION ROOT_COUNT_ONLY = .FALSE. P(1) = '{{1,2,5,6},{3,4,7,8}}' P(2) = '{{1,2,5,6},{3,4,7,8}}' P(3) = '{{1,2,5,6},{3,4,7,8}}' P(4) = '{{1,2,5,6},{3,4,7,8}}' P(5) = '{{1,2,5,6},{3,4,7,8}}' P(6) = '{{1,2,5,6},{3,4,7,8}}' P(7) = '{{1,2,5,6},{3,4,7,8}}' P(8) = '{{1,2,5,6},{3,4,7,8}}' NUM_SETS(1) = 2 NUM_INDICES(1,1) = 4 INDEX(1,1,1) = 1 INDEX(1,1,2) = 2 INDEX(1,1,3) = 5 INDEX(1,1,4) = 6 NUM_INDICES(1,2) = 4 INDEX(1,2,1) = 3 INDEX(1,2,2) = 4 INDEX(1,2,3) = 7 INDEX(1,2,4) = 8 NUM_SETS(2) = 2 NUM_INDICES(2,1) = 4 INDEX(2,1,1) = 1 INDEX(2,1,2) = 2 INDEX(2,1,3) = 5 INDEX(2,1,4) = 6 NUM_INDICES(2,2) = 4 INDEX(2,2,1) = 3 INDEX(2,2,2) = 4 INDEX(2,2,3) = 7 INDEX(2,2,4) = 8 NUM_SETS(3) = 2 NUM_INDICES(3,1) = 4 INDEX(3,1,1) = 1 INDEX(3,1,2) = 2 INDEX(3,1,3) = 5 INDEX(3,1,4) = 6 NUM_INDICES(3,2) = 4 INDEX(3,2,1) = 3 INDEX(3,2,2) = 4 INDEX(3,2,3) = 7 INDEX(3,2,4) = 8 NUM_SETS(4) = 2 NUM_INDICES(4,1) = 4 INDEX(4,1,1) = 1 INDEX(4,1,2) = 2 INDEX(4,1,3) = 5 INDEX(4,1,4) = 6 NUM_INDICES(4,2) = 4 INDEX(4,2,1) = 3 INDEX(4,2,2) = 4 INDEX(4,2,3) = 7 INDEX(4,2,4) = 8 NUM_SETS(5) = 2 NUM_INDICES(5,1) = 4 INDEX(5,1,1) = 1 INDEX(5,1,2) = 2 INDEX(5,1,3) = 5 INDEX(5,1,4) = 6 NUM_INDICES(5,2) = 4 INDEX(5,2,1) = 3 INDEX(5,2,2) = 4 INDEX(5,2,3) = 7 INDEX(5,2,4) = 8 NUM_SETS(6) = 2 NUM_INDICES(6,1) = 4 INDEX(6,1,1) = 1 INDEX(6,1,2) = 2 INDEX(6,1,3) = 5 INDEX(6,1,4) = 6 NUM_INDICES(6,2) = 4 INDEX(6,2,1) = 3 INDEX(6,2,2) = 4 INDEX(6,2,3) = 7 INDEX(6,2,4) = 8 NUM_SETS(7) = 2 NUM_INDICES(7,1) = 4 INDEX(7,1,1) = 1 INDEX(7,1,2) = 2 INDEX(7,1,3) = 5 INDEX(7,1,4) = 6 NUM_INDICES(7,2) = 4 INDEX(7,2,1) = 3 INDEX(7,2,2) = 4 INDEX(7,2,3) = 7 INDEX(7,2,4) = 8 NUM_SETS(8) = 2 NUM_INDICES(8,1) = 4 INDEX(8,1,1) = 1 INDEX(8,1,2) = 2 INDEX(8,1,3) = 5 INDEX(8,1,4) = 6 NUM_INDICES(8,2) = 4 INDEX(8,2,1) = 3 INDEX(8,2,2) = 4 INDEX(8,2,3) = 7 INDEX(8,2,4) = 8 / SHAR_EOF fi # end of overwriting check if test -f 'OUTPUT.DAT' then echo shar: will not over-write existing file "'OUTPUT.DAT'" else cat << SHAR_EOF > 'OUTPUT.DAT' TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS. TRACKTOL, FINALTOL = 1.00000000000000E-04 1.00000000000000E-14 SINGTOL (0 SETS DEFAULT) = 0.00000000000000E+00 SSPAR(5) (0 SETS DEFAULT) = 1.00000000000000E+00 NUMBER OF EQUATIONS = 2 ****** COEFFICIENT TABLEAU ****** POLYNOMIAL( 1)%NUM_TERMS = 6 POLYNOMIAL( 1)%TERM( 1)%DEG( 1) = 2 POLYNOMIAL( 1)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 1)%COEF = ( -9.80000000000000E-04, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 2)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 2)%DEG( 2) = 2 POLYNOMIAL( 1)%TERM( 2)%COEF = ( 9.78000000000000E+05, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 3)%DEG( 1) = 1 POLYNOMIAL( 1)%TERM( 3)%DEG( 2) = 1 POLYNOMIAL( 1)%TERM( 3)%COEF = ( -9.80000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 4)%DEG( 1) = 1 POLYNOMIAL( 1)%TERM( 4)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 4)%COEF = ( -2.35000000000000E+02, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 5)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 5)%DEG( 2) = 1 POLYNOMIAL( 1)%TERM( 5)%COEF = ( 8.89000000000000E+04, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 6)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 6)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 6)%COEF = ( -1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 2)%NUM_TERMS = 6 POLYNOMIAL( 2)%TERM( 1)%DEG( 1) = 2 POLYNOMIAL( 2)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 1)%COEF = ( -1.00000000000000E-02, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 2)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 2)%DEG( 2) = 2 POLYNOMIAL( 2)%TERM( 2)%COEF = ( -9.84000000000000E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 3)%DEG( 1) = 1 POLYNOMIAL( 2)%TERM( 3)%DEG( 2) = 1 POLYNOMIAL( 2)%TERM( 3)%COEF = ( -2.97000000000000E+01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 4)%DEG( 1) = 1 POLYNOMIAL( 2)%TERM( 4)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 4)%COEF = ( 9.87000000000000E-03, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 5)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 5)%DEG( 2) = 1 POLYNOMIAL( 2)%TERM( 5)%COEF = ( -1.24000000000000E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 6)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 6)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 6)%COEF = ( -2.50000000000000E-01, 0.00000000000000E+00) GENERALIZED PLP BEZOUT NUMBER (BPLP) = 4 BASED ON THE FOLLOWING SYSTEM PARTITION: P( 1) = {{x1,x2}} P( 2) = {{x1,x2}} PATH NUMBER = 1 ARCLEN = 1.26816675401253E+00 NFE = 72 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.21295805531714E-19 X( 1) = ( 1.61478579234357E-02, 1.68496955498881E+00) X( 2) = ( 2.67994739614461E-04, 4.42802993973661E-03) X( 3) = ( -1.25823744345070E-01, 1.63473363096121E-01) PATH NUMBER = 2 ARCLEN = 1.13629335006822E+00 NFE = 59 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.21930498807596E-19 X( 1) = ( 1.61478579234359E-02, -1.68496955498881E+00) X( 2) = ( 2.67994739614461E-04, -4.42802993973661E-03) X( 3) = ( -3.38381531362193E-02, 1.87673189619949E-01) PATH NUMBER = 3 ARCLEN = 1.12476921900360E+00 NFE = 77 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.36842264197237E-19 X( 1) = ( 2.34233851959121E+03, -2.71046941433355E-11) X( 2) = ( -7.88344824094120E-01, 9.12116375191414E-15) X( 3) = ( 7.51175382996960E-05, -1.28579733549813E-03) PATH NUMBER = 4 ARCLEN = 1.18469379240591E+00 NFE = 87 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.72244501412495E-19 X( 1) = ( 9.08921229615388E-02, -3.17718831976256E-17) X( 2) = ( -9.11497098197499E-02, -1.65664238054724E-17) X( 3) = ( -3.91641639919536E-02, 3.73017249038080E-02) PB803, 48 FINITE SOLUTIONS, TOTAL DEGREE 256. TRACKTOL, FINALTOL = 1.00000000000000E-06 1.00000000000000E-12 SINGTOL (0 SETS DEFAULT) = 0.00000000000000E+00 SSPAR(5) (0 SETS DEFAULT) = 1.00000000000000E+00 NUMBER OF EQUATIONS = 8 ****** COEFFICIENT TABLEAU ****** POLYNOMIAL( 1)%NUM_TERMS = 17 POLYNOMIAL( 1)%TERM( 1)%DEG( 1) = 1 POLYNOMIAL( 1)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 1)%DEG( 3) = 1 POLYNOMIAL( 1)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM( 1)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM( 1)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM( 1)%COEF = ( -2.90965281036386E-02, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 2)%DEG( 1) = 1 POLYNOMIAL( 1)%TERM( 2)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM( 2)%DEG( 4) = 1 POLYNOMIAL( 1)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM( 2)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM( 2)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM( 2)%COEF = ( 1.23862737830566E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 3)%DEG( 2) = 1 POLYNOMIAL( 1)%TERM( 3)%DEG( 3) = 1 POLYNOMIAL( 1)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM( 3)%COEF = ( 2.15085387051146E-02, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 4)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 4)%DEG( 2) = 1 POLYNOMIAL( 1)%TERM( 4)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM( 4)%DEG( 4) = 1 POLYNOMIAL( 1)%TERM( 4)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM( 4)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM( 4)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM( 4)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM( 4)%COEF = ( 1.67560227205193E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 5)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 5)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 5)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM( 5)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM( 5)%DEG( 5) = 1 POLYNOMIAL( 1)%TERM( 5)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM( 5)%DEG( 7) = 1 POLYNOMIAL( 1)%TERM( 5)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM( 5)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 6)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 6)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 6)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM( 6)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM( 6)%DEG( 5) = 1 POLYNOMIAL( 1)%TERM( 6)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM( 6)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM( 6)%DEG( 8) = 1 POLYNOMIAL( 1)%TERM( 6)%COEF = ( -7.00449587631292E-02, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 7)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 7)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 7)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM( 7)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM( 7)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM( 7)%DEG( 6) = 1 POLYNOMIAL( 1)%TERM( 7)%DEG( 7) = 1 POLYNOMIAL( 1)%TERM( 7)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM( 7)%COEF = ( -2.70632938682637E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 8)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM( 8)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 8)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM( 8)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM( 8)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM( 8)%DEG( 6) = 1 POLYNOMIAL( 1)%TERM( 8)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM( 8)%DEG( 8) = 1 POLYNOMIAL( 1)%TERM( 8)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM( 9)%DEG( 1) = 1 POLYNOMIAL( 1)%TERM( 9)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM( 9)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM( 9)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM( 9)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM( 9)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM( 9)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM( 9)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM( 9)%COEF = ( -6.15842911676544E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(10)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(10)%DEG( 2) = 1 POLYNOMIAL( 1)%TERM(10)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM(10)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM(10)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM(10)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM(10)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM(10)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM(10)%COEF = ( 4.55239231804051E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(11)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(11)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM(11)%DEG( 3) = 1 POLYNOMIAL( 1)%TERM(11)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM(11)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM(11)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM(11)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM(11)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM(11)%COEF = ( 1.30935803481163E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(12)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(12)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM(12)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM(12)%DEG( 4) = 1 POLYNOMIAL( 1)%TERM(12)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM(12)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM(12)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM(12)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM(12)%COEF = ( -1.29409522551260E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(13)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(13)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM(13)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM(13)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM(13)%DEG( 5) = 1 POLYNOMIAL( 1)%TERM(13)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM(13)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM(13)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM(13)%COEF = ( 4.18258151868904E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(14)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(14)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM(14)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM(14)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM(14)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM(14)%DEG( 6) = 1 POLYNOMIAL( 1)%TERM(14)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM(14)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM(14)%COEF = ( -5.41265877365274E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(15)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(15)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM(15)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM(15)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM(15)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM(15)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM(15)%DEG( 7) = 1 POLYNOMIAL( 1)%TERM(15)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM(15)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(16)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(16)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM(16)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM(16)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM(16)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM(16)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM(16)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM(16)%DEG( 8) = 1 POLYNOMIAL( 1)%TERM(16)%COEF = ( 1.50925910357667E-01, 0.00000000000000E+00) POLYNOMIAL( 1)%TERM(17)%DEG( 1) = 0 POLYNOMIAL( 1)%TERM(17)%DEG( 2) = 0 POLYNOMIAL( 1)%TERM(17)%DEG( 3) = 0 POLYNOMIAL( 1)%TERM(17)%DEG( 4) = 0 POLYNOMIAL( 1)%TERM(17)%DEG( 5) = 0 POLYNOMIAL( 1)%TERM(17)%DEG( 6) = 0 POLYNOMIAL( 1)%TERM(17)%DEG( 7) = 0 POLYNOMIAL( 1)%TERM(17)%DEG( 8) = 0 POLYNOMIAL( 1)%TERM(17)%COEF = ( -2.38536449761034E-02, 0.00000000000000E+00) POLYNOMIAL( 2)%NUM_TERMS = 17 POLYNOMIAL( 2)%TERM( 1)%DEG( 1) = 1 POLYNOMIAL( 2)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 1)%DEG( 3) = 1 POLYNOMIAL( 2)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM( 1)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM( 1)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM( 1)%COEF = ( 3.40782576514583E-02, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 2)%DEG( 1) = 1 POLYNOMIAL( 2)%TERM( 2)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM( 2)%DEG( 4) = 1 POLYNOMIAL( 2)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM( 2)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM( 2)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM( 2)%COEF = ( -1.56062186852569E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 3)%DEG( 2) = 1 POLYNOMIAL( 2)%TERM( 3)%DEG( 3) = 1 POLYNOMIAL( 2)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM( 3)%COEF = ( -2.70999143496647E-02, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 4)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 4)%DEG( 2) = 1 POLYNOMIAL( 2)%TERM( 4)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM( 4)%DEG( 4) = 1 POLYNOMIAL( 2)%TERM( 4)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM( 4)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM( 4)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM( 4)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM( 4)%COEF = ( -1.96248864280182E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 5)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 5)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 5)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM( 5)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM( 5)%DEG( 5) = 1 POLYNOMIAL( 2)%TERM( 5)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM( 5)%DEG( 7) = 1 POLYNOMIAL( 2)%TERM( 5)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM( 5)%COEF = ( 2.20738619037920E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 6)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 6)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 6)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM( 6)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM( 6)%DEG( 5) = 1 POLYNOMIAL( 2)%TERM( 6)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM( 6)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM( 6)%DEG( 8) = 1 POLYNOMIAL( 2)%TERM( 6)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 7)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 7)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 7)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM( 7)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM( 7)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM( 7)%DEG( 6) = 1 POLYNOMIAL( 2)%TERM( 7)%DEG( 7) = 1 POLYNOMIAL( 2)%TERM( 7)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM( 7)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 8)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM( 8)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 8)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM( 8)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM( 8)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM( 8)%DEG( 6) = 1 POLYNOMIAL( 2)%TERM( 8)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM( 8)%DEG( 8) = 1 POLYNOMIAL( 2)%TERM( 8)%COEF = ( -8.52868531952443E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM( 9)%DEG( 1) = 1 POLYNOMIAL( 2)%TERM( 9)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM( 9)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM( 9)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM( 9)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM( 9)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM( 9)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM( 9)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM( 9)%COEF = ( 7.21283767677873E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(10)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(10)%DEG( 2) = 1 POLYNOMIAL( 2)%TERM(10)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM(10)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM(10)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM(10)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM(10)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM(10)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM(10)%COEF = ( -5.73583559517377E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(11)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(11)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM(11)%DEG( 3) = 1 POLYNOMIAL( 2)%TERM(11)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM(11)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM(11)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM(11)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM(11)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM(11)%COEF = ( 6.31988450754851E-02, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(12)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(12)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM(12)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM(12)%DEG( 4) = 1 POLYNOMIAL( 2)%TERM(12)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM(12)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM(12)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM(12)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM(12)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(13)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(13)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM(13)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM(13)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM(13)%DEG( 5) = 1 POLYNOMIAL( 2)%TERM(13)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM(13)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM(13)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM(13)%COEF = ( -1.45259531732747E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(14)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(14)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM(14)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM(14)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM(14)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM(14)%DEG( 6) = 1 POLYNOMIAL( 2)%TERM(14)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM(14)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM(14)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(15)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(15)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM(15)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM(15)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM(15)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM(15)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM(15)%DEG( 7) = 1 POLYNOMIAL( 2)%TERM(15)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM(15)%COEF = ( -4.75625621282099E-01, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(16)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(16)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM(16)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM(16)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM(16)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM(16)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM(16)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM(16)%DEG( 8) = 1 POLYNOMIAL( 2)%TERM(16)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 2)%TERM(17)%DEG( 1) = 0 POLYNOMIAL( 2)%TERM(17)%DEG( 2) = 0 POLYNOMIAL( 2)%TERM(17)%DEG( 3) = 0 POLYNOMIAL( 2)%TERM(17)%DEG( 4) = 0 POLYNOMIAL( 2)%TERM(17)%DEG( 5) = 0 POLYNOMIAL( 2)%TERM(17)%DEG( 6) = 0 POLYNOMIAL( 2)%TERM(17)%DEG( 7) = 0 POLYNOMIAL( 2)%TERM(17)%DEG( 8) = 0 POLYNOMIAL( 2)%TERM(17)%COEF = ( 1.91169832725054E-02, 0.00000000000000E+00) POLYNOMIAL( 3)%NUM_TERMS = 17 POLYNOMIAL( 3)%TERM( 1)%DEG( 1) = 1 POLYNOMIAL( 3)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM( 1)%DEG( 3) = 1 POLYNOMIAL( 3)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM( 1)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM( 1)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM( 1)%COEF = ( -6.02977987152187E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 2)%DEG( 1) = 1 POLYNOMIAL( 3)%TERM( 2)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM( 2)%DEG( 4) = 1 POLYNOMIAL( 3)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM( 2)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM( 2)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM( 2)%COEF = ( -1.31668276721907E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM( 3)%DEG( 2) = 1 POLYNOMIAL( 3)%TERM( 3)%DEG( 3) = 1 POLYNOMIAL( 3)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM( 3)%COEF = ( -7.58247385552503E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 4)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM( 4)%DEG( 2) = 1 POLYNOMIAL( 3)%TERM( 4)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM( 4)%DEG( 4) = 1 POLYNOMIAL( 3)%TERM( 4)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM( 4)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM( 4)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM( 4)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM( 4)%COEF = ( 1.04706028642251E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 5)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM( 5)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM( 5)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM( 5)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM( 5)%DEG( 5) = 1 POLYNOMIAL( 3)%TERM( 5)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM( 5)%DEG( 7) = 1 POLYNOMIAL( 3)%TERM( 5)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM( 5)%COEF = ( -5.51846547594801E-02, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 6)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM( 6)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM( 6)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM( 6)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM( 6)%DEG( 5) = 1 POLYNOMIAL( 3)%TERM( 6)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM( 6)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM( 6)%DEG( 8) = 1 POLYNOMIAL( 3)%TERM( 6)%COEF = ( 1.23100969126526E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 7)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM( 7)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM( 7)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM( 7)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM( 7)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM( 7)%DEG( 6) = 1 POLYNOMIAL( 3)%TERM( 7)%DEG( 7) = 1 POLYNOMIAL( 3)%TERM( 7)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM( 7)%COEF = ( 3.18608752805224E-02, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 8)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM( 8)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM( 8)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM( 8)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM( 8)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM( 8)%DEG( 6) = 1 POLYNOMIAL( 3)%TERM( 8)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM( 8)%DEG( 8) = 1 POLYNOMIAL( 3)%TERM( 8)%COEF = ( 2.13217132988111E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM( 9)%DEG( 1) = 1 POLYNOMIAL( 3)%TERM( 9)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM( 9)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM( 9)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM( 9)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM( 9)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM( 9)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM( 9)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM( 9)%COEF = ( -2.14660295785905E-02, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(10)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(10)%DEG( 2) = 1 POLYNOMIAL( 3)%TERM(10)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM(10)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM(10)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM(10)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM(10)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM(10)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM(10)%COEF = ( -6.01805216517440E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(11)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(11)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM(11)%DEG( 3) = 1 POLYNOMIAL( 3)%TERM(11)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM(11)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM(11)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM(11)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM(11)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM(11)%COEF = ( 0.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(12)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(12)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM(12)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM(12)%DEG( 4) = 1 POLYNOMIAL( 3)%TERM(12)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM(12)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM(12)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM(12)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM(12)%COEF = ( 2.44181586600211E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(13)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(13)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM(13)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM(13)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM(13)%DEG( 5) = 1 POLYNOMIAL( 3)%TERM(13)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM(13)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM(13)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM(13)%COEF = ( 3.63148829331866E-02, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(14)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(14)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM(14)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM(14)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM(14)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM(14)%DEG( 6) = 1 POLYNOMIAL( 3)%TERM(14)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM(14)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM(14)%COEF = ( -2.09664074370650E-02, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(15)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(15)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM(15)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM(15)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM(15)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM(15)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM(15)%DEG( 7) = 1 POLYNOMIAL( 3)%TERM(15)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM(15)%COEF = ( -7.13438431923148E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(16)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(16)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM(16)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM(16)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM(16)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM(16)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM(16)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM(16)%DEG( 8) = 1 POLYNOMIAL( 3)%TERM(16)%COEF = ( 6.15504845632630E-01, 0.00000000000000E+00) POLYNOMIAL( 3)%TERM(17)%DEG( 1) = 0 POLYNOMIAL( 3)%TERM(17)%DEG( 2) = 0 POLYNOMIAL( 3)%TERM(17)%DEG( 3) = 0 POLYNOMIAL( 3)%TERM(17)%DEG( 4) = 0 POLYNOMIAL( 3)%TERM(17)%DEG( 5) = 0 POLYNOMIAL( 3)%TERM(17)%DEG( 6) = 0 POLYNOMIAL( 3)%TERM(17)%DEG( 7) = 0 POLYNOMIAL( 3)%TERM(17)%DEG( 8) = 0 POLYNOMIAL( 3)%TERM(17)%COEF = ( 5.47700898171009E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%NUM_TERMS = 17 POLYNOMIAL( 4)%TERM( 1)%DEG( 1) = 1 POLYNOMIAL( 4)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM( 1)%DEG( 3) = 1 POLYNOMIAL( 4)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM( 1)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM( 1)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM( 1)%COEF = ( 4.78568869541663E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 2)%DEG( 1) = 1 POLYNOMIAL( 4)%TERM( 2)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM( 2)%DEG( 4) = 1 POLYNOMIAL( 4)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM( 2)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM( 2)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM( 2)%COEF = ( 1.12420351802601E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM( 3)%DEG( 2) = 1 POLYNOMIAL( 4)%TERM( 3)%DEG( 3) = 1 POLYNOMIAL( 4)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM( 3)%COEF = ( 6.47403003665440E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 4)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM( 4)%DEG( 2) = 1 POLYNOMIAL( 4)%TERM( 4)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM( 4)%DEG( 4) = 1 POLYNOMIAL( 4)%TERM( 4)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM( 4)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM( 4)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM( 4)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM( 4)%COEF = ( -8.31026120840329E-02, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 5)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM( 5)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM( 5)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM( 5)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM( 5)%DEG( 5) = 1 POLYNOMIAL( 4)%TERM( 5)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM( 5)%DEG( 7) = 1 POLYNOMIAL( 4)%TERM( 5)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM( 5)%COEF = ( 3.90625000000000E-02, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 6)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM( 6)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM( 6)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM( 6)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM( 6)%DEG( 5) = 1 POLYNOMIAL( 4)%TERM( 6)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM( 6)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM( 6)%DEG( 8) = 1 POLYNOMIAL( 4)%TERM( 6)%COEF = ( 1.75112396907823E-02, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 7)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM( 7)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM( 7)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM( 7)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM( 7)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM( 7)%DEG( 6) = 1 POLYNOMIAL( 4)%TERM( 7)%DEG( 7) = 1 POLYNOMIAL( 4)%TERM( 7)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM( 7)%COEF = ( 6.76582346706593E-02, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 8)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM( 8)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM( 8)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM( 8)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM( 8)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM( 8)%DEG( 6) = 1 POLYNOMIAL( 4)%TERM( 8)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM( 8)%DEG( 8) = 1 POLYNOMIAL( 4)%TERM( 8)%COEF = ( -1.01101189493172E-02, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM( 9)%DEG( 1) = 1 POLYNOMIAL( 4)%TERM( 9)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM( 9)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM( 9)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM( 9)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM( 9)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM( 9)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM( 9)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM( 9)%COEF = ( 1.96623270912993E-04, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(10)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(10)%DEG( 2) = 1 POLYNOMIAL( 4)%TERM(10)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM(10)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM(10)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM(10)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM(10)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM(10)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM(10)%COEF = ( 5.00438376735814E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(11)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(11)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM(11)%DEG( 3) = 1 POLYNOMIAL( 4)%TERM(11)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM(11)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM(11)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM(11)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM(11)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM(11)%COEF = ( -5.00000000000000E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(12)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(12)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM(12)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM(12)%DEG( 4) = 1 POLYNOMIAL( 4)%TERM(12)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM(12)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM(12)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM(12)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM(12)%COEF = ( 5.05897096673464E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(13)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(13)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM(13)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM(13)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM(13)%DEG( 5) = 1 POLYNOMIAL( 4)%TERM(13)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM(13)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM(13)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM(13)%COEF = ( -2.64395379672260E-02, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(14)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(14)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM(14)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM(14)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM(14)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM(14)%DEG( 6) = 1 POLYNOMIAL( 4)%TERM(14)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM(14)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM(14)%COEF = ( 1.95686833484385E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(15)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(15)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM(15)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM(15)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM(15)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM(15)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM(15)%DEG( 7) = 1 POLYNOMIAL( 4)%TERM(15)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM(15)%COEF = ( 1.95312500000000E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(16)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(16)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM(16)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM(16)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM(16)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM(16)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM(16)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM(16)%DEG( 8) = 1 POLYNOMIAL( 4)%TERM(16)%COEF = ( 2.26388865536500E-01, 0.00000000000000E+00) POLYNOMIAL( 4)%TERM(17)%DEG( 1) = 0 POLYNOMIAL( 4)%TERM(17)%DEG( 2) = 0 POLYNOMIAL( 4)%TERM(17)%DEG( 3) = 0 POLYNOMIAL( 4)%TERM(17)%DEG( 4) = 0 POLYNOMIAL( 4)%TERM(17)%DEG( 5) = 0 POLYNOMIAL( 4)%TERM(17)%DEG( 6) = 0 POLYNOMIAL( 4)%TERM(17)%DEG( 7) = 0 POLYNOMIAL( 4)%TERM(17)%DEG( 8) = 0 POLYNOMIAL( 4)%TERM(17)%COEF = ( -3.39187450014371E-01, 0.00000000000000E+00) POLYNOMIAL( 5)%NUM_TERMS = 3 POLYNOMIAL( 5)%TERM( 1)%DEG( 1) = 2 POLYNOMIAL( 5)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 5)%TERM( 1)%DEG( 3) = 0 POLYNOMIAL( 5)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 5)%TERM( 1)%DEG( 5) = 0 POLYNOMIAL( 5)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 5)%TERM( 1)%DEG( 7) = 0 POLYNOMIAL( 5)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 5)%TERM( 1)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 5)%TERM( 2)%DEG( 1) = 0 POLYNOMIAL( 5)%TERM( 2)%DEG( 2) = 2 POLYNOMIAL( 5)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 5)%TERM( 2)%DEG( 4) = 0 POLYNOMIAL( 5)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 5)%TERM( 2)%DEG( 6) = 0 POLYNOMIAL( 5)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 5)%TERM( 2)%DEG( 8) = 0 POLYNOMIAL( 5)%TERM( 2)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 5)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 5)%TERM( 3)%DEG( 2) = 0 POLYNOMIAL( 5)%TERM( 3)%DEG( 3) = 0 POLYNOMIAL( 5)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 5)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 5)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 5)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 5)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 5)%TERM( 3)%COEF = ( -1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 6)%NUM_TERMS = 3 POLYNOMIAL( 6)%TERM( 1)%DEG( 1) = 0 POLYNOMIAL( 6)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 6)%TERM( 1)%DEG( 3) = 2 POLYNOMIAL( 6)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 6)%TERM( 1)%DEG( 5) = 0 POLYNOMIAL( 6)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 6)%TERM( 1)%DEG( 7) = 0 POLYNOMIAL( 6)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 6)%TERM( 1)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 6)%TERM( 2)%DEG( 1) = 0 POLYNOMIAL( 6)%TERM( 2)%DEG( 2) = 0 POLYNOMIAL( 6)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 6)%TERM( 2)%DEG( 4) = 2 POLYNOMIAL( 6)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 6)%TERM( 2)%DEG( 6) = 0 POLYNOMIAL( 6)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 6)%TERM( 2)%DEG( 8) = 0 POLYNOMIAL( 6)%TERM( 2)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 6)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 6)%TERM( 3)%DEG( 2) = 0 POLYNOMIAL( 6)%TERM( 3)%DEG( 3) = 0 POLYNOMIAL( 6)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 6)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 6)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 6)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 6)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 6)%TERM( 3)%COEF = ( -1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 7)%NUM_TERMS = 3 POLYNOMIAL( 7)%TERM( 1)%DEG( 1) = 0 POLYNOMIAL( 7)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 7)%TERM( 1)%DEG( 3) = 0 POLYNOMIAL( 7)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 7)%TERM( 1)%DEG( 5) = 2 POLYNOMIAL( 7)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 7)%TERM( 1)%DEG( 7) = 0 POLYNOMIAL( 7)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 7)%TERM( 1)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 7)%TERM( 2)%DEG( 1) = 0 POLYNOMIAL( 7)%TERM( 2)%DEG( 2) = 0 POLYNOMIAL( 7)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 7)%TERM( 2)%DEG( 4) = 0 POLYNOMIAL( 7)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 7)%TERM( 2)%DEG( 6) = 2 POLYNOMIAL( 7)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 7)%TERM( 2)%DEG( 8) = 0 POLYNOMIAL( 7)%TERM( 2)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 7)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 7)%TERM( 3)%DEG( 2) = 0 POLYNOMIAL( 7)%TERM( 3)%DEG( 3) = 0 POLYNOMIAL( 7)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 7)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 7)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 7)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 7)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 7)%TERM( 3)%COEF = ( -1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 8)%NUM_TERMS = 3 POLYNOMIAL( 8)%TERM( 1)%DEG( 1) = 0 POLYNOMIAL( 8)%TERM( 1)%DEG( 2) = 0 POLYNOMIAL( 8)%TERM( 1)%DEG( 3) = 0 POLYNOMIAL( 8)%TERM( 1)%DEG( 4) = 0 POLYNOMIAL( 8)%TERM( 1)%DEG( 5) = 0 POLYNOMIAL( 8)%TERM( 1)%DEG( 6) = 0 POLYNOMIAL( 8)%TERM( 1)%DEG( 7) = 2 POLYNOMIAL( 8)%TERM( 1)%DEG( 8) = 0 POLYNOMIAL( 8)%TERM( 1)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 8)%TERM( 2)%DEG( 1) = 0 POLYNOMIAL( 8)%TERM( 2)%DEG( 2) = 0 POLYNOMIAL( 8)%TERM( 2)%DEG( 3) = 0 POLYNOMIAL( 8)%TERM( 2)%DEG( 4) = 0 POLYNOMIAL( 8)%TERM( 2)%DEG( 5) = 0 POLYNOMIAL( 8)%TERM( 2)%DEG( 6) = 0 POLYNOMIAL( 8)%TERM( 2)%DEG( 7) = 0 POLYNOMIAL( 8)%TERM( 2)%DEG( 8) = 2 POLYNOMIAL( 8)%TERM( 2)%COEF = ( 1.00000000000000E+00, 0.00000000000000E+00) POLYNOMIAL( 8)%TERM( 3)%DEG( 1) = 0 POLYNOMIAL( 8)%TERM( 3)%DEG( 2) = 0 POLYNOMIAL( 8)%TERM( 3)%DEG( 3) = 0 POLYNOMIAL( 8)%TERM( 3)%DEG( 4) = 0 POLYNOMIAL( 8)%TERM( 3)%DEG( 5) = 0 POLYNOMIAL( 8)%TERM( 3)%DEG( 6) = 0 POLYNOMIAL( 8)%TERM( 3)%DEG( 7) = 0 POLYNOMIAL( 8)%TERM( 3)%DEG( 8) = 0 POLYNOMIAL( 8)%TERM( 3)%COEF = ( -1.00000000000000E+00, 0.00000000000000E+00) GENERALIZED PLP BEZOUT NUMBER (BPLP) = 256 BASED ON THE FOLLOWING SYSTEM PARTITION: P( 1) = {{1,2,3,4,5,6,7,8}} P( 2) = {{1,2,3,4,5,6,7,8}} P( 3) = {{1,2,3,4,5,6,7,8}} P( 4) = {{1,2,3,4,5,6,7,8}} P( 5) = {{1,2,3,4,5,6,7,8}} P( 6) = {{1,2,3,4,5,6,7,8}} P( 7) = {{1,2,3,4,5,6,7,8}} P( 8) = {{1,2,3,4,5,6,7,8}} GENERALIZED PLP BEZOUT NUMBER (BPLP) = 96 BASED ON THE FOLLOWING SYSTEM PARTITION: P( 1) = {{1,2,5,6},{3,4,7,8}} P( 2) = {{1,2,5,6},{3,4,7,8}} P( 3) = {{1,2,5,6},{3,4,7,8}} P( 4) = {{1,2,5,6},{3,4,7,8}} P( 5) = {{1,2,5,6},{3,4,7,8}} P( 6) = {{1,2,5,6},{3,4,7,8}} P( 7) = {{1,2,5,6},{3,4,7,8}} P( 8) = {{1,2,5,6},{3,4,7,8}} PATH NUMBER = 1 ARCLEN = 1.28131220396818E+01 NFE = 178 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.97318001552014E-12 X( 1) = ( -4.68812311870644E+12, 1.36663234380927E+14) X( 2) = ( 1.36663234380926E+14, 4.68812311870628E+12) X( 3) = ( 2.62650325728421E-01, 3.35459744114971E-01) X( 4) = ( 9.67434839262407E-02, 3.44741322948753E+00) X( 5) = ( -5.99203469950116E+00, -5.56976907146642E+00) X( 6) = ( -1.45819191659967E+00, 1.98116799869560E+00) X( 7) = ( -9.58760678473091E+10, 7.67917400914658E+13) X( 8) = ( -7.67917400914659E+13, -9.58760678471873E+10) X( 9) = ( 8.65973959207622E-15, 9.10382880192628E-15) PATH NUMBER = 2 ARCLEN = 4.75276882396933E+01 NFE = 237 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.40443527482436E-13 X( 1) = ( 5.03968635957377E+14, -4.61113236904094E+13) X( 2) = ( -4.61113236904071E+13, -5.03968635957380E+14) X( 3) = ( 9.75520262908556E-01, 1.50487415519503E+00) X( 4) = ( -6.06568421404215E+00, 8.30488870375774E+00) X( 5) = ( -1.85442382372649E+01, -6.68282600122044E+00) X( 6) = ( 6.43930192753342E-01, -4.63625031690354E+00) X( 7) = ( -8.32387458815294E+13, -2.23342511418664E+14) X( 8) = ( -2.23342511418663E+14, 8.32387458815306E+13) X( 9) = ( -6.66133814775094E-16, -8.60422844084496E-16) PATH NUMBER = 3 ARCLEN = 3.67498572010943E+00 NFE = 101 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.37443113861194E-13 X( 1) = ( -1.77426252777192E-01, -4.79744070589443E-15) X( 2) = ( -9.84134099005572E-01, 1.23650124763146E-14) X( 3) = ( -9.99539785563458E-01, -2.93516840736575E-14) X( 4) = ( 3.03350799515865E-02, -1.67609463337487E-14) X( 5) = ( 9.06036666598339E-01, 3.37470803483856E-14) X( 6) = ( -4.23199195154467E-01, 2.58970014254136E-14) X( 7) = ( -3.37009206790820E-01, -2.37578690993572E-14) X( 8) = ( -9.41501351320397E-01, -4.43630298528148E-15) X( 9) = ( 1.55508231890239E-01, -4.31681545990077E-01) PATH NUMBER = 4 ARCLEN = 6.14001030131391E+00 NFE = 127 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.05139624521203E-14 X( 1) = ( 1.06989712752767E+15, -3.59352678705648E+14) X( 2) = ( -3.59352678705648E+14, -1.06989712752767E+15) X( 3) = ( -3.67421057474348E-01, 3.06972737479819E-01) X( 4) = ( -4.00851917686063E-01, -1.21687189297555E-01) X( 5) = ( 4.49641404842324E+14, 1.16465971163348E+15) X( 6) = ( -1.16465971163348E+15, 4.49641404842324E+14) X( 7) = ( 4.31305646406564E-01, -1.14017716406510E-01) X( 8) = ( -4.07653464594750E-01, -4.34439562028677E-01) X( 9) = ( -3.33066907387547E-16, -3.88578058618805E-16) PATH NUMBER = 5 ARCLEN = 7.96410800977882E+00 NFE = 108 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.83680693596968E-15 X( 1) = ( -8.45196877409835E-01, 7.92235415426024E-01) X( 2) = ( 1.12566385494450E+00, 5.94844452320603E-01) X( 3) = ( -3.54281084626982E-01, 8.41957515842726E-02) X( 4) = ( -9.39458343171758E-01, -3.17512345375022E-02) X( 5) = ( -1.16156403958416E+00, 1.51629198529726E+00) X( 6) = ( 1.72860198938115E+00, 1.01889865593729E+00) X( 7) = ( -9.87295286067430E-01, -5.58588121492123E-03) X( 8) = ( -1.62572967705491E-01, 3.39227011099110E-02) X( 9) = ( -1.46089672926839E+00, 7.77746893345623E-01) PATH NUMBER = 6 ARCLEN = 3.70877863768666E+01 NFE = 237 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.66384808686470E-12 X( 1) = ( -3.09341001513798E+13, -9.38854040459371E+12) X( 2) = ( -9.38854040459582E+12, 3.09341001513846E+13) X( 3) = ( 1.94695108654604E-01, -1.14516915920560E+00) X( 4) = ( -4.55742607686115E-01, 1.73681392553232E+00) X( 5) = ( 1.19568749242829E+01, 7.52832267269614E+00) X( 6) = ( 1.93837594137993E-01, -2.75731057974336E+00) X( 7) = ( 1.75365142571057E+13, 4.69559248668396E+12) X( 8) = ( -4.69559248668137E+12, 1.75365142571082E+13) X( 9) = ( 1.06581410364015E-14, 5.63438184997267E-15) PATH NUMBER = 7 ARCLEN = 3.59416333745506E+01 NFE = 214 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.32878581961392E-13 X( 1) = ( -8.17515578953426E+13, 4.76413493755506E+14) X( 2) = ( 4.76413493755506E+14, 8.17515578953425E+13) X( 3) = ( 2.41843904717902E-01, 4.22473046285439E-01) X( 4) = ( 2.69143430446357E-01, 4.19176576780283E+00) X( 5) = ( -7.22405536179091E+00, -7.47909950436445E+00) X( 6) = ( -1.88688951236610E+00, 2.46375684619348E+00) X( 7) = ( -3.70459977837651E+13, 2.68912553809903E+14) X( 8) = ( -2.68912553809903E+14, -3.70459977837651E+13) X( 9) = ( 2.77555756156289E-15, 2.22044604925031E-15) PATH NUMBER = 8 ARCLEN = 9.04221683947724E+00 NFE = 162 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 7.69517887192478E-14 X( 1) = ( -6.63730983313674E+00, -3.37024022615234E+01) X( 2) = ( -5.12584519483177E+00, 2.72718303846448E+01) X( 3) = ( 8.23452083654023E+14, 8.58585027192926E+13) X( 4) = ( -8.58585027192922E+13, 8.23452083654024E+14) X( 5) = ( -2.36900955746572E+16, -1.32585375438259E+16) X( 6) = ( 1.32585375438259E+16, -2.36900955746571E+16) X( 7) = ( 2.76786086276549E+00, -1.81595949276651E+00) X( 8) = ( -1.00648862878868E+00, 1.29109091402415E+00) X( 9) = ( 0.00000000000000E+00, 1.11022302462516E-16) PATH NUMBER = 9 ARCLEN = 1.46279536891286E+01 NFE = 207 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.15177032495645E-14 X( 1) = ( -2.11425926844066E+13, 1.72037577307898E+14) X( 2) = ( -1.72037577307898E+14, -2.11425926844066E+13) X( 3) = ( -4.21228971197384E-01, -4.58913175480601E-01) X( 4) = ( 1.05371602800178E+00, -1.81269502663675E-01) X( 5) = ( 1.57458063926332E+14, -7.23970126184296E+13) X( 6) = ( -7.23970126184295E+13, -1.57458063926332E+14) X( 7) = ( 7.11014294424574E-01, 7.79890529163677E-01) X( 8) = ( -1.17675691585771E+00, 4.68634890632046E-01) X( 9) = ( 3.99680288865056E-15, -6.49480469405717E-15) PATH NUMBER = 10 ARCLEN = 1.35808481374228E+01 NFE = 180 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.61499359219293E-15 X( 1) = ( 6.17653599891829E-01, -6.36907669143173E-02) X( 2) = ( -7.90592480178201E-01, -4.97586714404775E-02) X( 3) = ( -8.96723890425260E-01, -6.96526650740098E-02) X( 4) = ( 4.67530808227781E-01, -1.33593781852390E-01) X( 5) = ( 4.08955073213484E-01, -5.09587694769521E-01) X( 6) = ( -1.06340978278925E+00, -1.95971935180570E-01) X( 7) = ( 9.07104450970909E-01, 9.39529209909668E-02) X( 8) = ( -4.68117719657311E-01, 1.82059147162842E-01) X( 9) = ( 1.46286692868714E+00, 8.01614467086453E-01) PATH NUMBER = 11 ARCLEN = 5.37998990289468E+02 NFE = 726 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 9.15266338188155E-13 X( 1) = ( 2.27962463355709E+01, -1.10654424455428E+01) X( 2) = ( -1.33275482994241E+01, 1.40965561976714E+01) X( 3) = ( -1.56705807240068E+13, -5.46925841636636E+13) X( 4) = ( -5.46925841636634E+13, 1.56705807240062E+13) X( 5) = ( 1.90890571029270E+14, -1.87620958336193E+15) X( 6) = ( 1.87620958336193E+15, 1.90890571029269E+14) X( 7) = ( 2.39488179154370E-01, -6.94579328058866E+00) X( 8) = ( -1.79766877326257E+00, 3.27784390012773E-01) X( 9) = ( 1.44328993201270E-15, 4.71844785465692E-16) PATH NUMBER = 12 ARCLEN = 8.61145933633052E+00 NFE = 170 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.88347191338802E-18 X( 1) = ( -9.99996101363610E-01, 1.62432978856020E-16) X( 2) = ( 2.79235699365525E-03, -6.39400252365255E-16) X( 3) = ( -7.87055930991066E-01, 1.84410947142838E-16) X( 4) = ( -6.16881643017351E-01, 2.25394910997989E-16) X( 5) = ( -9.64617850094969E-01, 0.00000000000000E+00) X( 6) = ( 2.63652049637700E-01, -6.13715029597035E-16) X( 7) = ( -7.91552581806904E-01, 2.01165662159061E-16) X( 8) = ( -6.11101063846910E-01, 0.00000000000000E+00) X( 9) = ( -4.15814594308820E-01, -6.26738416969252E-01) PATH NUMBER = 13 ARCLEN = 1.38345665839938E+01 NFE = 199 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.18671760187826E-15 X( 1) = ( 8.10309088191083E-01, 2.65552743188495E-15) X( 2) = ( 5.86002714665153E-01, 2.01004902199171E-15) X( 3) = ( 5.45184304735715E-01, -2.09363413010314E-16) X( 4) = ( -8.38316213531529E-01, -1.85010550176931E-14) X( 5) = ( 9.37646003039468E-01, 9.04984871554547E-16) X( 6) = ( 3.47591675654211E-01, 1.60532631531640E-15) X( 7) = ( 3.68121016397535E-01, -3.18597343142448E-15) X( 8) = ( 9.29777885995598E-01, 1.23945983126574E-14) X( 9) = ( -1.63223051865495E-01, 1.93784395129653E-01) PATH NUMBER = 14 ARCLEN = 2.91644383373811E+02 NFE = 461 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.88995978989988E-15 X( 1) = ( -3.00885004528297E+14, -6.97357121297707E+14) X( 2) = ( 6.97357121297707E+14, -3.00885004528297E+14) X( 3) = ( -2.72827919201391E-01, -6.14130374276733E-01) X( 4) = ( -1.02609297765551E+00, 1.65580328942657E-01) X( 5) = ( -1.13616812113119E+15, -3.50729453434280E+14) X( 6) = ( -3.50729453434280E+14, 1.13616812113119E+15) X( 7) = ( -8.18113712794237E-01, -1.79983395342702E-02) X( 8) = ( -2.45657356474988E-01, 1.80176831311342E-01) X( 9) = ( -7.77156117237610E-16, -5.55111512312578E-17) PATH NUMBER = 15 ARCLEN = 1.26937683285245E+01 NFE = 175 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.50535527814252E-14 X( 1) = ( 1.16231199225214E+00, -1.87679591182667E-01) X( 2) = ( 3.33772014514003E-01, 6.53566596499132E-01) X( 3) = ( 6.06760099173187E+00, -1.30472521573230E+00) X( 4) = ( -1.32197811553589E+00, -5.98841381705157E+00) X( 5) = ( -1.53635384798664E+00, -1.93378873591131E-01) X( 6) = ( 2.52300382664370E-01, -1.17755816865436E+00) X( 7) = ( -5.91454538188601E+00, 7.03796500475207E-01) X( 8) = ( 7.13926056317323E-01, 5.83062672224837E+00) X( 9) = ( 1.51229114422788E-01, 3.04819362228380E-02) PATH NUMBER = 16 ARCLEN = 6.92454738232423E+00 NFE = 126 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.77353203171806E-13 X( 1) = ( -8.01563642853246E-01, -4.27103037978817E-01) X( 2) = ( 8.40201275122707E-01, -4.07462208321089E-01) X( 3) = ( -3.63818630922403E+00, -3.13016201582524E+00) X( 4) = ( 3.19905480977762E+00, -3.55983666075757E+00) X( 5) = ( 1.08100630676357E+00, 8.35636949103319E-02) X( 6) = ( 2.00993027177798E-01, -4.49432910599007E-01) X( 7) = ( 6.88801025268024E-01, -3.94152999316949E+00) X( 8) = ( -4.06296944890635E+00, -6.68213220542693E-01) X( 9) = ( 1.81231475527714E-01, -2.37265857683588E-01) PATH NUMBER = 17 ARCLEN = 1.03707883723803E+01 NFE = 149 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.30620400511869E-14 X( 1) = ( -3.85879098943321E+14, 1.65540882448604E+15) X( 2) = ( 1.65540882448604E+15, 3.85879098943321E+14) X( 3) = ( -2.40605941379952E-01, 1.98351707833757E-01) X( 4) = ( 3.02885631755228E-01, 3.45760032535714E-01) X( 5) = ( -1.34230782681325E+15, 1.81276841578323E+15) X( 6) = ( 1.81276841578323E+15, 1.34230782681325E+15) X( 7) = ( -5.36828911547947E-01, -3.21046569930255E-01) X( 8) = ( -1.41776007317474E-01, 9.69195603467200E-02) X( 9) = ( 3.33066907387547E-16, 9.15933995315754E-16) PATH NUMBER = 18 ARCLEN = 6.88750320385733E+00 NFE = 147 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.29995704076617E-18 X( 1) = ( 1.16805813859714E+00, 2.64606830344746E-01) X( 2) = ( 4.41763649679254E-01, -6.99641452928462E-01) X( 3) = ( 2.18650479698318E+00, 2.11047855621063E+00) X( 4) = ( -2.22789002770864E+00, 2.07127435811125E+00) X( 5) = ( 1.11182382946579E+00, -1.91784047471524E-01) X( 6) = ( 3.68368798447796E-01, 5.78849443787667E-01) X( 7) = ( -1.37945707030438E+00, -1.76735543503195E+00) X( 8) = ( 1.94659755754041E+00, -1.25243707470597E+00) X( 9) = ( -8.85377153938158E-02, 1.91107549966979E-03) PATH NUMBER = 19 ARCLEN = 5.07109599936369E+02 NFE = 661 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.62085615608261E-16 X( 1) = ( 1.08707913283362E+00, 1.12206976693261E-01) X( 2) = ( 2.52695630148077E-01, -4.82706657214905E-01) X( 3) = ( -7.60926702188131E-01, 3.00226576434989E-01) X( 4) = ( 7.73530340563732E-01, 2.95334787449215E-01) X( 5) = ( 1.11306763775108E+00, -1.06662124290859E-01) X( 6) = ( -2.25085865185255E-01, -5.27452750639071E-01) X( 7) = ( 5.60758078600111E-01, -2.75952812846165E-01) X( 8) = ( -8.89908277794076E-01, -1.73886200384034E-01) X( 9) = ( -1.07253331094511E+00, -3.30265048691959E-02) PATH NUMBER = 20 ARCLEN = 4.34769560243156E+00 NFE = 156 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.12994630712465E-16 X( 1) = ( -1.78654801865840E-02, -2.42461036816496E-01) X( 2) = ( 1.02882744214239E+00, -4.21031037065328E-03) X( 3) = ( -3.32182462985674E+00, 2.10811115213515E+00) X( 4) = ( -2.17826339358012E+00, -3.21484333266451E+00) X( 5) = ( 1.09509784985601E+00, -4.19501638508560E-02) X( 6) = ( 1.00815582087486E-01, 4.55678906801469E-01) X( 7) = ( 2.99182814752126E+00, -1.24565781632953E+00) X( 8) = ( 1.30852462014192E+00, 2.84808864862652E+00) X( 9) = ( 4.16724044659178E-03, 6.98473761480181E-02) PATH NUMBER = 21 ARCLEN = 3.75576498058983E+01 NFE = 230 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.20138870966074E-14 X( 1) = ( 5.66681012997789E-01, 9.49812332342608E-01) X( 2) = ( -1.05747950726404E+00, 2.04572108301208E-01) X( 3) = ( -5.13046264129965E+13, 4.14327789257192E+13) X( 4) = ( 4.14327789257192E+13, 5.13046264129967E+13) X( 5) = ( 2.14194623548208E+15, -6.36147286417629E+14) X( 6) = ( 6.36147286417629E+14, 2.14194623548208E+15) X( 7) = ( -1.38766663667076E+00, 4.01586428293570E-01) X( 8) = ( 1.56734772843837E-01, 3.36972371950278E-01) X( 9) = ( 7.77156117237610E-16, -9.15933995315754E-16) PATH NUMBER = 22 ARCLEN = 1.63049478854804E+02 NFE = 393 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.01530656571487E-15 X( 1) = ( 1.52882796872256E+00, -5.93006252708740E-01) X( 2) = ( -7.34212672558196E-01, -1.23479827937268E+00) X( 3) = ( -6.27822700511963E-01, 2.57790977457449E-01) X( 4) = ( 8.42157099175800E-01, 1.92181515531187E-01) X( 5) = ( 1.34052542652375E+00, -1.04876828069925E+00) X( 6) = ( -1.25119464901040E+00, -1.12364654685896E+00) X( 7) = ( 7.03035713465315E-01, 2.44536619572995E-01) X( 8) = ( -7.83389442654811E-01, 2.19454038373670E-01) X( 9) = ( -7.12698055649068E-01, -7.65021598874602E-01) PATH NUMBER = 23 ARCLEN = 3.57857328889957E+01 NFE = 205 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.00851867116788E-15 X( 1) = ( 9.51044815428272E-01, 3.30314788813084E-03) X( 2) = ( -3.09237559760445E-01, 1.01586679057785E-02) X( 3) = ( -1.67483475490117E-01, 4.01571993917389E-02) X( 4) = ( 9.86715940318370E-01, 6.81621431787958E-03) X( 5) = ( 3.58070010433481E-01, -1.34366160073985E-01) X( 6) = ( -9.44687224087698E-01, -5.09295469577899E-02) X( 7) = ( 8.88159812042096E-01, 2.54383575921023E-02) X( 8) = ( -4.62819970372659E-01, 4.88166638087575E-02) X( 9) = ( 1.78664949929667E+00, 7.26712773506335E+00) PATH NUMBER = 24 ARCLEN = 1.03269095608157E+01 NFE = 140 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.94411446426841E-14 X( 1) = ( 1.27925568125788E+00, 2.82792348757027E-01) X( 2) = ( -4.22066367675192E-01, 8.57125197528307E-01) X( 3) = ( 6.69598674729508E+00, -1.38313258399835E+00) X( 4) = ( -1.39815366279856E+00, -6.62404834220216E+00) X( 5) = ( -1.40358102984341E+00, 1.44410309311772E-01) X( 6) = ( 2.03645160065723E-01, 9.95317397174933E-01) X( 7) = ( 2.31705420969464E-01, -6.46288795781497E+00) X( 8) = ( 6.53969930518643E+00, 2.28983949423503E-01) X( 9) = ( -4.48241039626215E-02, 4.03307946954118E-02) PATH NUMBER = 25 ARCLEN = 9.91394276328260E+00 NFE = 128 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.52968200081570E-15 X( 1) = ( 7.91094851343680E+13, -7.64861916065379E+14) X( 2) = ( 7.64861916065379E+14, 7.91094851343680E+13) X( 3) = ( -6.81736244765053E-01, -4.24674711317191E-01) X( 4) = ( 7.97838477594439E-01, -2.27483463286841E-01) X( 5) = ( -3.06710728082736E+14, -9.73209783896462E+14) X( 6) = ( 9.73209783896463E+14, -3.06710728082736E+14) X( 7) = ( -8.88398688000389E-01, 6.12027860710752E-02) X( 8) = ( -4.39810011730760E-01, -2.52543438150895E-01) X( 9) = ( -1.11022302462516E-16, 7.77156117237610E-16) PATH NUMBER = 26 ARCLEN = 2.04917244427531E+01 NFE = 153 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.43451143664486E-14 X( 1) = ( -1.32795196370748E+15, -7.94099463257786E+14) X( 2) = ( 7.94099463257786E+14, -1.32795196370748E+15) X( 3) = ( -5.42208682168513E-01, -5.77054482053827E-01) X( 4) = ( 1.07329380781683E+00, -1.98245798242311E-01) X( 5) = ( -1.32168747602277E+15, 1.74569065148824E+15) X( 6) = ( 1.74569065148823E+15, 1.32168747602277E+15) X( 7) = ( -1.10424490365911E+00, -2.54069699684807E-01) X( 8) = ( -3.84658829915540E-01, 4.28308014199849E-01) X( 9) = ( -4.44089209850063E-16, -4.16333634234434E-16) PATH NUMBER = 27 ARCLEN = 5.20577863735281E+00 NFE = 127 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.94526095082827E-15 X( 1) = ( 1.04178169441146E+13, 8.69333097226214E+14) X( 2) = ( 8.69333097226214E+14, -1.04178169441149E+13) X( 3) = ( -2.01943122049798E-02, 4.04009945858891E-01) X( 4) = ( 8.31753554802623E-01, -2.00567702802609E-01) X( 5) = ( -1.22129798549178E+15, 1.48605434068264E+14) X( 6) = ( -1.48605434068263E+14, -1.22129798549178E+15) X( 7) = ( -4.65950312443383E-01, 2.67385040285712E-01) X( 8) = ( -3.64301888143482E-01, 8.29354132953790E-02) X( 9) = ( -3.33066907387547E-16, 5.27355936696949E-16) PATH NUMBER = 28 ARCLEN = 2.65245179076856E+01 NFE = 207 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.93918828905320E-17 X( 1) = ( -8.28253379807935E-01, 5.66208311141470E-01) X( 2) = ( -9.39953195542937E-01, -4.98922658704704E-01) X( 3) = ( -2.88293160145085E-01, -1.92429259310048E-01) X( 4) = ( 9.78330979423583E-01, -5.67047762338649E-02) X( 5) = ( 1.28667055008929E+00, 7.48750669668275E-02) X( 6) = ( 1.18237411569360E-01, -8.14797468275652E-01) X( 7) = ( 4.88755859727675E-01, 1.68192955396118E-01) X( 8) = ( -8.93239162923570E-01, 9.20305511971850E-02) X( 9) = ( 3.10970405338154E-01, -4.19127065932796E-01) PATH NUMBER = 29 ARCLEN = 8.85446068789414E+00 NFE = 141 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.41503897789377E-17 X( 1) = ( 8.82849248270716E-02, -2.09844535749672E-01) X( 2) = ( 1.01812160806675E+00, 1.81963617285457E-02) X( 3) = ( 6.08392880071458E-01, 1.71205029496556E-03) X( 4) = ( -7.93638933696674E-01, 1.31243461674665E-03) X( 5) = ( -4.22090915226493E-01, -5.75142790295975E-01) X( 6) = ( 1.09620780507533E+00, -2.21456685144900E-01) X( 7) = ( -9.54400887068395E-01, 2.08881184804464E-02) X( 8) = ( 3.06255751857134E-01, 6.50947408694792E-02) X( 9) = ( -3.53334050794062E-01, 1.64321323003135E-01) PATH NUMBER = 30 ARCLEN = 7.45798468507404E+00 NFE = 161 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.90328835025646E-12 X( 1) = ( 4.16915381126867E+13, -1.88129992509394E+13) X( 2) = ( 1.88129992509392E+13, 4.16915381126857E+13) X( 3) = ( -3.30740317472709E-01, 6.18871732025788E-01) X( 4) = ( 4.32950976946130E-01, -3.71650170804494E+00) X( 5) = ( 1.05971171140609E+00, 5.37805681608669E-01) X( 6) = ( 1.12502924276234E-01, -4.61304673421384E-01) X( 7) = ( 3.68339215320663E+11, -2.71120930849526E+12) X( 8) = ( -2.71120930849530E+12, -3.68339215320722E+11) X( 9) = ( 9.32587340685131E-15, 1.29340982368831E-14) PATH NUMBER = 31 ARCLEN = 4.47421024385894E+01 NFE = 237 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.82827539548787E-15 X( 1) = ( 2.30506045454831E+15, -7.78515936573353E+14) X( 2) = ( -7.78515936573354E+14, -2.30506045454831E+15) X( 3) = ( -3.31568292511495E-01, 5.95861859006165E-01) X( 4) = ( -1.12943331532645E+00, 3.44468351242309E-01) X( 5) = ( 3.27032892006872E+15, 1.95293740222478E+15) X( 6) = ( -1.95293740222478E+15, 3.27032892006872E+15) X( 7) = ( -1.05284124681766E+00, 1.94213433878986E-01) X( 8) = ( -5.01783706453979E-01, -6.13255707442164E-02) X( 9) = ( -1.11022302462516E-16, -1.94289029309402E-16) PATH NUMBER = 32 ARCLEN = 1.57391717242020E+01 NFE = 169 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.80242722673518E-12 X( 1) = ( 1.45566148330375E+14, 2.45715282529433E+14) X( 2) = ( 2.45715282529430E+14, -1.45566148330375E+14) X( 3) = ( 2.22952440982190E-01, 5.86647171653170E-01) X( 4) = ( -2.40040482997917E-01, 6.25203480226599E+00) X( 5) = ( -5.78111808185858E+00, 1.95134609186809E+01) X( 6) = ( -5.62225044435826E+00, -3.09497304104469E+00) X( 7) = ( -9.36818379731719E+13, 9.65225692273807E+13) X( 8) = ( 9.65225692273812E+13, 9.36818379731721E+13) X( 9) = ( -1.99840144432528E-15, 2.77555756156289E-15) PATH NUMBER = 33 ARCLEN = 9.54518397946433E+00 NFE = 136 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.60947843709405E-13 X( 1) = ( -4.21364093217994E+00, 1.61404701987159E-01) X( 2) = ( 2.34149221455992E+00, -5.49460114250335E-01) X( 3) = ( -1.42808764660853E+14, 9.11535548031979E+12) X( 4) = ( 9.11535548031979E+12, 1.42808764660853E+14) X( 5) = ( 9.06872295489020E+14, 7.39990415705178E+14) X( 6) = ( 7.39990415705177E+14, -9.06872295489020E+14) X( 7) = ( -7.09390121642192E-01, 4.22499400017444E-02) X( 8) = ( 4.37032231912015E-01, -2.39538814985627E-01) X( 9) = ( 9.99200722162641E-16, 7.49400541621981E-16) PATH NUMBER = 34 ARCLEN = 2.55474758666369E+01 NFE = 211 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 8.15713370982724E-14 X( 1) = ( -2.80935947968405E+14, -6.23786210325981E+14) X( 2) = ( 6.23786210325981E+14, -2.80935947968404E+14) X( 3) = ( 5.39161209322357E-01, 1.68842780147786E-01) X( 4) = ( 5.32865106552390E-02, -1.78967467701699E+00) X( 5) = ( -6.09585644091031E+00, -5.11062144770141E+00) X( 6) = ( 1.97048017153239E+00, -2.58279174561151E+00) X( 7) = ( 4.05477221384833E+13, 5.53860669786486E+12) X( 8) = ( 5.53860669786482E+12, -4.05477221384833E+13) X( 9) = ( -7.77156117237610E-16, 5.55111512312578E-16) PATH NUMBER = 35 ARCLEN = 6.98446380197642E+01 NFE = 285 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 8.58978259572403E-18 X( 1) = ( 6.17653599891829E-01, 6.36907669143173E-02) X( 2) = ( -7.90592480178201E-01, 4.97586714404776E-02) X( 3) = ( -8.96723890425260E-01, 6.96526650740098E-02) X( 4) = ( 4.67530808227781E-01, 1.33593781852390E-01) X( 5) = ( 4.08955073213484E-01, 5.09587694769520E-01) X( 6) = ( -1.06340978278925E+00, 1.95971935180570E-01) X( 7) = ( 9.07104450970909E-01, -9.39529209909667E-02) X( 8) = ( -4.68117719657311E-01, -1.82059147162841E-01) X( 9) = ( -2.68712134074006E-01, -2.87057140779620E+00) PATH NUMBER = 36 ARCLEN = 5.73523250899784E+00 NFE = 161 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.61559792031297E-16 X( 1) = ( 6.35337829645393E+14, -1.65208553431825E+14) X( 2) = ( 1.65208553431826E+14, 6.35337829645393E+14) X( 3) = ( -5.24374410774192E-01, -7.50470052596345E-01) X( 4) = ( -9.81941350256630E-01, 2.48248774760002E-01) X( 5) = ( 1.05406570400194E+15, -1.15258870111266E+14) X( 6) = ( 1.15258870111266E+14, 1.05406570400194E+15) X( 7) = ( -7.96776575424231E-01, 1.74016552156281E-02) X( 8) = ( -3.24721705790805E-01, -1.18240854245503E-01) X( 9) = ( 9.99200722162641E-16, 3.88578058618805E-16) PATH NUMBER = 37 ARCLEN = 2.71700425940614E+02 NFE = 424 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.21638601453785E-13 X( 1) = ( 1.54618367926336E+00, -4.61103887267863E+00) X( 2) = ( 1.40744145397933E-01, 2.77103297321157E+00) X( 3) = ( 3.33115102674693E+14, 4.55625675133190E+13) X( 4) = ( 4.55625675133205E+13, -3.33115102674694E+14) X( 5) = ( 1.52869241578575E+15, 2.26025518735155E+15) X( 6) = ( 2.26025518735155E+15, -1.52869241578575E+15) X( 7) = ( 1.77475302406521E+00, 5.50441758651758E+00) X( 8) = ( -2.00380770066703E+00, -7.58478065940621E-01) X( 9) = ( 4.44089209850063E-16, 2.22044604925031E-16) PATH NUMBER = 38 ARCLEN = 3.21295420367874E+01 NFE = 165 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.44249354411040E-13 X( 1) = ( 5.54535656619785E+00, -6.42820025453552E+00) X( 2) = ( -5.57001580444291E+00, 2.52264783219132E+00) X( 3) = ( 6.48949821951992E+13, 2.61791450854239E+13) X( 4) = ( -2.61791450854238E+13, 6.48949821951972E+13) X( 5) = ( -2.74149029134088E+14, -6.17620417639359E+14) X( 6) = ( -6.17620417639359E+14, 2.74149029134088E+14) X( 7) = ( -5.78579166827194E-01, 1.50696730852159E+00) X( 8) = ( -1.03150156910402E+00, -6.61381123143413E-01) X( 9) = ( -1.66533453693773E-15, -4.44089209850063E-16) PATH NUMBER = 39 ARCLEN = 1.51806282816415E+01 NFE = 181 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.49215623138328E-16 X( 1) = ( 6.15575098704302E-02, 2.40269210579696E-16) X( 2) = ( 9.98103538205607E-01, 7.98592798033961E-17) X( 3) = ( -9.61509161663197E-01, -4.40854622675687E-17) X( 4) = ( 2.74772873547839E-01, 2.02061733550597E-16) X( 5) = ( 6.17807316614373E-01, 2.85842754237625E-16) X( 6) = ( 7.86329523506366E-01, -7.04233527118322E-17) X( 7) = ( -6.73376870835452E-02, 1.26238509879016E-16) X( 8) = ( -9.97730242048540E-01, -1.95353235263722E-16) X( 9) = ( 6.73114267746677E-01, 2.32198161155180E+00) PATH NUMBER = 40 ARCLEN = 4.12211752837191E+01 NFE = 212 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.95116550807445E-13 X( 1) = ( 1.16231199225451E+00, 1.87679591197858E-01) X( 2) = ( 3.33772014514965E-01, -6.53566596509143E-01) X( 3) = ( 6.06760099179521E+00, 1.30472521568105E+00) X( 4) = ( -1.32197811548440E+00, 5.98841381711306E+00) X( 5) = ( -1.53635384798432E+00, 1.93378873616404E-01) X( 6) = ( 2.52300382673651E-01, 1.17755816865092E+00) X( 7) = ( -5.91454538191194E+00, -7.03796500392309E-01) X( 8) = ( 7.13926056234035E-01, -5.83062672227526E+00) X( 9) = ( -3.12464098711607E-02, -2.69065555447091E-02) PATH NUMBER = 41 ARCLEN = 7.67472624571258E+00 NFE = 154 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.30592869992450E-17 X( 1) = ( -1.29626865906874E-01, 1.85405888581043E-01) X( 2) = ( 1.00902900917828E+00, 2.38185265624943E-02) X( 3) = ( -5.06099762670942E-01, -1.97612071536567E+00) X( 4) = ( -2.20339260732317E+00, 4.53897422425640E-01) X( 5) = ( -1.25562726235550E+00, 4.31546989110051E-02) X( 6) = ( -7.11621633744569E-02, -7.61447008943107E-01) X( 7) = ( 2.34519131484164E-01, 1.86661190037688E+00) X( 8) = ( 2.11473191547315E+00, -2.07003165976451E-01) X( 9) = ( -9.40330403016092E-02, 1.84950455818849E-01) PATH NUMBER = 42 ARCLEN = 8.16752493105972E+00 NFE = 173 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.86129538079350E-16 X( 1) = ( 9.76148462455547E-01, -2.62122356780367E-16) X( 2) = ( 2.17104074686936E-01, -1.03057827574727E-16) X( 3) = ( 7.09264760346991E-02, -1.55358848612641E-16) X( 4) = ( 9.97481546193863E-01, -2.56747537034248E-16) X( 5) = ( 9.26212713628612E-01, -3.40502790780857E-16) X( 6) = ( -3.77001338343410E-01, -1.46807496825793E-16) X( 7) = ( -1.53496719696746E-01, 1.89763169973905E-16) X( 8) = ( -9.88149157284637E-01, 1.08597762386165E-16) X( 9) = ( 9.55422953719358E-02, -7.80699063683327E-01) PATH NUMBER = 43 ARCLEN = 2.11349911179627E+01 NFE = 278 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.16509753494675E-12 X( 1) = ( 1.94105799014519E+01, -1.08848222006946E+01) X( 2) = ( -1.09000125940112E+01, 1.30377941285022E+01) X( 3) = ( -2.46341191052299E+12, -8.94253014337284E+12) X( 4) = ( -8.94253014337264E+12, 2.46341191052250E+12) X( 5) = ( 3.42528540070442E+13, -3.05554052756424E+14) X( 6) = ( 3.05554052756431E+14, 3.42528540070430E+13) X( 7) = ( 3.20614990912948E-01, -6.16605161036113E+00) X( 8) = ( -1.61550974280200E+00, 2.65982886125962E-01) X( 9) = ( 8.88178419700125E-15, 2.80331313717852E-15) PATH NUMBER = 44 ARCLEN = 2.38273618399074E+01 NFE = 239 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.05784308264088E-14 X( 1) = ( 1.27925568125805E+00, -2.82792348757007E-01) X( 2) = ( -4.22066367675229E-01, -8.57125197528376E-01) X( 3) = ( 6.69598674729621E+00, 1.38313258399864E+00) X( 4) = ( -1.39815366279890E+00, 6.62404834220327E+00) X( 5) = ( -1.40358102984342E+00, -1.44410309311880E-01) X( 6) = ( 2.03645160065804E-01, -9.95317397174896E-01) X( 7) = ( 2.31705420969072E-01, 6.46288795781603E+00) X( 8) = ( 6.53969930518755E+00, -2.28983949423156E-01) X( 9) = ( -1.37175113916118E-01, 4.42221601392030E-02) PATH NUMBER = 45 ARCLEN = 1.39151416036216E+01 NFE = 166 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.62157336180867E-13 X( 1) = ( -3.59213282135333E-01, -1.75620811047344E-01) X( 2) = ( 9.51945474476294E-01, -6.62698963743397E-02) X( 3) = ( 1.07619680311174E+00, 3.86550605399786E-02) X( 4) = ( -1.01778566380084E-01, 4.08734904182504E-01) X( 5) = ( -1.33456507217690E+00, 6.81624099524591E-01) X( 6) = ( 8.74702052835551E-01, 1.03997894212163E+00) X( 7) = ( -1.07398005488248E+00, 6.47210247186224E-02) X( 8) = ( -1.65402932515309E-01, -4.20240975310061E-01) X( 9) = ( -2.50997811263730E-01, -1.81169410910482E-01) PATH NUMBER = 46 ARCLEN = 2.62450979678920E+01 NFE = 207 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 7.65892510477824E-14 X( 1) = ( 2.48606282037549E+13, -5.09540362218641E+13) X( 2) = ( -5.09540362218642E+13, -2.48606282037548E+13) X( 3) = ( -6.21025959325629E-01, 3.01511640579541E-01) X( 4) = ( 8.58680770724208E-01, 2.32143939137826E-01) X( 5) = ( 1.23608013769703E+13, -5.35358474451623E+13) X( 6) = ( -5.35358474451624E+13, -1.23608013769702E+13) X( 7) = ( 6.42660103291178E-01, 4.14591907942647E-01) X( 8) = ( -9.22601890798119E-01, 3.06148234809921E-01) X( 9) = ( -6.43929354282591E-15, -1.38222766565832E-14) PATH NUMBER = 47 ARCLEN = 1.53942394273634E+01 NFE = 200 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.46749651353963E-12 X( 1) = ( -8.92601260463733E+13, -3.56248552881061E+13) X( 2) = ( 3.56248552881075E+13, -8.92601260463737E+13) X( 3) = ( 4.83293772072497E-01, -4.11104350066793E-01) X( 4) = ( -4.51563963738752E-01, -4.48340750925082E+00) X( 5) = ( -6.77928366588111E+00, -3.70702241754950E+00) X( 6) = ( -1.36261720747812E+00, 2.35923247631516E+00) X( 7) = ( 2.66736764754465E+12, 6.31467562593376E+12) X( 8) = ( -6.31467562593448E+12, 2.66736764754493E+12) X( 9) = ( -7.88258347483861E-15, -1.49880108324396E-15) PATH NUMBER = 48 ARCLEN = 7.38234442731714E+00 NFE = 125 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.98449037765257E-13 X( 1) = ( -8.01563642854010E-01, 4.27103037977736E-01) X( 2) = ( 8.40201275123276E-01, 4.07462208322527E-01) X( 3) = ( -3.63818630922741E+00, 3.13016201582224E+00) X( 4) = ( 3.19905480977637E+00, 3.55983666076158E+00) X( 5) = ( 1.08100630676366E+00, -8.35636949104900E-02) X( 6) = ( 2.00993027178593E-01, 4.49432910599106E-01) X( 7) = ( 6.88801025265177E-01, 3.94152999316834E+00) X( 8) = ( -4.06296944890651E+00, 6.68213220539622E-01) X( 9) = ( 9.47395885227615E-02, -4.15440954219847E-02) PATH NUMBER = 49 ARCLEN = 3.60389010705651E+01 NFE = 168 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.14762019272591E-15 X( 1) = ( 7.06674110388772E+13, 3.76479782411352E+14) X( 2) = ( 3.76479782411352E+14, -7.06674110388770E+13) X( 3) = ( -7.25758336025283E-01, 8.66013386802363E-01) X( 4) = ( -1.30859699014962E+00, -6.82556179898607E-01) X( 5) = ( 2.01096629187416E+14, 5.85132149048016E+14) X( 6) = ( 5.85132149048016E+14, -2.01096629187416E+14) X( 7) = ( -9.99016924770774E-01, -3.18782968435312E-01) X( 8) = ( -2.97821997627481E-01, 2.73263399711532E-01) X( 9) = ( 4.44089209850063E-16, 2.19269047363468E-15) PATH NUMBER = 50 ARCLEN = 9.88329916288832E+00 NFE = 192 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 7.33148257425828E-16 X( 1) = ( 1.17448859228741E+14, 2.13499866968392E+14) X( 2) = ( -2.13499866968392E+14, 1.17448859228741E+14) X( 3) = ( -6.40002994438962E-01, -4.26189183004144E-01) X( 4) = ( 9.44935873393997E-01, -2.51403661015866E-01) X( 5) = ( 6.43335357661161E+13, 2.27214706799840E+14) X( 6) = ( -2.27214706799840E+14, 6.43335357661161E+13) X( 7) = ( 6.17928909472138E-01, -7.12917301215236E-01) X( 8) = ( -1.14023030418129E+00, -4.48006156889629E-01) X( 9) = ( 2.10942374678780E-15, -2.10942374678780E-15) PATH NUMBER = 51 ARCLEN = 8.61353655998727E+01 NFE = 291 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.76333386012933E-12 X( 1) = ( -4.41508312643033E+00, -2.38855240468937E+00) X( 2) = ( 2.54406074087246E+00, 2.34257239299561E+00) X( 3) = ( 6.02052133008785E+12, -2.77609478889390E+11) X( 4) = ( 2.77609478888704E+11, 6.02052133008644E+12) X( 5) = ( -4.36189604194440E+13, -3.85296882949516E+13) X( 6) = ( -3.85296882949516E+13, 4.36189604194439E+13) X( 7) = ( -8.93314215320189E-01, 1.38042249903808E+00) X( 8) = ( -8.30695120203318E-01, -3.82860694126479E-01) X( 9) = ( -1.54321000422897E-14, -1.27398092075737E-14) PATH NUMBER = 52 ARCLEN = 5.13202575936238E+01 NFE = 241 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 8.97508369046091E-15 X( 1) = ( -6.33671876892610E+13, -7.82248442883025E+13) X( 2) = ( -7.82248442883026E+13, 6.33671876892610E+13) X( 3) = ( -4.52515987227243E-01, 4.20909697171704E-01) X( 4) = ( 1.22753330120548E+00, 2.34789898793375E-01) X( 5) = ( 9.98360031959916E+13, -1.28090486663625E+13) X( 6) = ( 1.28090486663625E+13, 9.98360031959917E+13) X( 7) = ( 5.77249894166398E-01, -5.09926804153385E-01) X( 8) = ( -1.02912207381421E+00, -5.66867270551422E-01) X( 9) = ( 5.44009282066327E-15, -2.77555756156289E-15) PATH NUMBER = 53 ARCLEN = 2.62713843850054E+01 NFE = 186 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.29882010665198E-14 X( 1) = ( -1.17580884606015E+00, -3.91945730962372E-01) X( 2) = ( 6.00333423168924E-01, -7.67662168813466E-01) X( 3) = ( -4.46316901221624E-01, 4.48073453470395E-02) X( 4) = ( -8.96273829690174E-01, -2.23126848790978E-02) X( 5) = ( -1.71041655462015E+00, 8.19910369153666E-01) X( 6) = ( 9.53617690809596E-01, 1.47059799982796E+00) X( 7) = ( -9.69616408977202E-01, 9.02774498392315E-03) X( 8) = ( -2.47341824528347E-01, -3.53900909769935E-02) X( 9) = ( -2.86335261783929E-01, -2.01142556068835E-01) PATH NUMBER = 54 ARCLEN = 8.71772904258144E+00 NFE = 161 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.14747474691947E-13 X( 1) = ( -1.05374849568344E+13, 9.48160767955412E+13) X( 2) = ( 9.48160767955416E+13, 1.05374849568355E+13) X( 3) = ( -9.22529828418918E-01, 8.93863833893693E-01) X( 4) = ( 9.01869864853589E-02, -6.96971090410134E-01) X( 5) = ( 6.98977107194009E+13, 8.81941382717839E+13) X( 6) = ( 8.81941382717834E+13, -6.98977107193999E+13) X( 7) = ( 1.27707424186016E-01, -8.33080008309553E-01) X( 8) = ( -6.94874949749171E-01, 6.87629908014062E-01) X( 9) = ( 6.66133814775094E-16, 6.52256026967279E-15) PATH NUMBER = 55 ARCLEN = 1.01628708821900E+01 NFE = 149 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.64710218083986E-16 X( 1) = ( -8.40062525275419E-01, -3.31061653116359E-01) X( 2) = ( 7.38680181298249E-01, -3.76499187848782E-01) X( 3) = ( 5.17100724931646E-01, -3.88067038518989E+00) X( 4) = ( 4.00539746007343E+00, 5.00998337719441E-01) X( 5) = ( -1.65699648586207E+00, 5.82716504385732E-02) X( 6) = ( -7.30400050240799E-02, -1.32195938335803E+00) X( 7) = ( 3.73775710005446E+00, -7.06361391302752E-01) X( 8) = ( -7.32043054625668E-01, -3.60662844741596E+00) X( 9) = ( -2.17819057123101E-01, -1.19798564150627E-01) PATH NUMBER = 56 ARCLEN = 9.33015066990628E+00 NFE = 158 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.87844329959378E-12 X( 1) = ( -9.72946321955175E+13, 3.99877292495156E+13) X( 2) = ( -3.99877292495141E+13, -9.72946321955194E+13) X( 3) = ( 5.54522609635061E-01, -7.62897332111254E-01) X( 4) = ( -1.31338352635994E+00, -4.11328557532582E+00) X( 5) = ( -3.25823863762093E+00, -3.26072756534385E-01) X( 6) = ( -5.06966205910349E-01, 1.79825993464350E+00) X( 7) = ( 6.90644648664386E+12, 2.93166637898680E+12) X( 8) = ( -2.93166637898734E+12, 6.90644648664504E+12) X( 9) = ( -4.21884749357559E-15, -5.99520433297585E-15) PATH NUMBER = 57 ARCLEN = 1.30784749189569E+01 NFE = 141 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.89448417503007E-14 X( 1) = ( -5.73993644466767E-01, 2.63874515550253E-01) X( 2) = ( -8.77471389081332E-01, -1.72612231859966E-01) X( 3) = ( -3.06129886067413E-01, -1.27633565998054E-01) X( 4) = ( 9.61367068432931E-01, -4.06425914724242E-02) X( 5) = ( 1.06286154111227E+00, -3.09983707316501E-02) X( 6) = ( -8.91250080067966E-02, -3.69671507746739E-01) X( 7) = ( 5.35586935983250E-01, -3.55587300380890E-02) X( 8) = ( -8.45528470021295E-01, -2.25241277423528E-02) X( 9) = ( 3.29813239008971E-01, -5.12580213622979E-01) PATH NUMBER = 58 ARCLEN = 2.32542467869342E+01 NFE = 172 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.32509819744771E-16 X( 1) = ( -7.82540497851946E-01, -4.50086222861456E-17) X( 2) = ( 6.22599686172125E-01, 9.25631656705557E-17) X( 3) = ( -8.29709626974048E-01, -2.04394026972552E-16) X( 4) = ( -5.58195248015053E-01, -9.36821557337821E-17) X( 5) = ( -8.50226890899773E-01, -5.52190266874492E-17) X( 6) = ( 5.26416407410431E-01, 1.22439279696536E-16) X( 7) = ( -7.55089439022002E-01, -2.09029041596714E-16) X( 8) = ( -6.55621795761427E-01, -1.81143771138551E-16) X( 9) = ( -9.33965053870513E-01, -3.76603958574031E-01) PATH NUMBER = 59 ARCLEN = 9.26152666860319E+00 NFE = 168 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.48125469175142E-13 X( 1) = ( 1.37171629075174E+01, -3.26495586746975E+01) X( 2) = ( -1.68789473451366E+01, 2.09430876387698E+01) X( 3) = ( 3.68178186087232E+14, 3.63229351045501E+14) X( 4) = ( -3.63229351045501E+14, 3.68178186087234E+14) X( 5) = ( -6.38208075102145E+15, -1.57124946358798E+16) X( 6) = ( 1.57124946358798E+16, -6.38208075102145E+15) X( 7) = ( -2.68009552528767E-02, -2.79025991693759E+00) X( 8) = ( -1.36332280100641E+00, -8.99654640258036E-02) X( 9) = ( 1.11022302462516E-16, 1.38777878078145E-16) PATH NUMBER = 60 ARCLEN = 1.34427744257294E+01 NFE = 175 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.26423133305875E-14 X( 1) = ( -1.29626865907250E-01, -1.85405888581809E-01) X( 2) = ( 1.00902900917846E+00, -2.38185265620578E-02) X( 3) = ( -5.06099762674546E-01, 1.97612071536438E+00) X( 4) = ( -2.20339260732167E+00, -4.53897422429026E-01) X( 5) = ( -1.25562726235594E+00, -4.31546989115320E-02) X( 6) = ( -7.11621633749768E-02, 7.61447008943500E-01) X( 7) = ( 2.34519131487466E-01, -1.86661190037578E+00) X( 8) = ( 2.11473191547215E+00, 2.07003165979994E-01) X( 9) = ( -7.55057664420448E-02, 6.99139503666090E-02) PATH NUMBER = 61 ARCLEN = 1.39221493283393E+01 NFE = 185 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 9.25763462027820E-17 X( 1) = ( 2.29357256355386E-01, 1.58919437495568E-16) X( 2) = ( 9.73342308212856E-01, -1.63414091278481E-16) X( 3) = ( 2.39309340396267E-01, 9.02110033146097E-17) X( 4) = ( -9.70943376103418E-01, -8.26947967765700E-17) X( 5) = ( -9.93991529928234E-01, 0.00000000000000E+00) X( 6) = ( 1.09457016362260E-01, -2.07151777617418E-16) X( 7) = ( -1.30933055767338E-01, 1.10708046670247E-16) X( 8) = ( 9.91391211836895E-01, 3.19797238317442E-16) X( 9) = ( -1.79884553238029E-01, 1.51526336978807E-01) PATH NUMBER = 62 ARCLEN = 6.04541441248726E+00 NFE = 169 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.12942615384363E-12 X( 1) = ( 9.67145100807588E+12, -3.95099976846184E+13) X( 2) = ( 3.95099976846180E+13, 9.67145100807577E+12) X( 3) = ( 2.06388654817995E-01, 6.25870999063409E-02) X( 4) = ( -5.44692972953123E-01, -3.55471596236317E+00) X( 5) = ( -2.92852733892974E+00, 9.15844726247381E-01) X( 6) = ( 3.89064784162263E-01, -1.42073712584800E+00) X( 7) = ( 1.69703165128132E+12, 1.74377506850663E+12) X( 8) = ( 1.74377506850664E+12, -1.69703165128145E+12) X( 9) = ( -4.55191440096314E-15, 1.54043444666740E-14) PATH NUMBER = 63 ARCLEN = 3.21199976117091E+01 NFE = 214 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 9.98899561823743E-13 X( 1) = ( 6.12504470299833E+13, -5.70662375417009E+13) X( 2) = ( -5.70662375417011E+13, -6.12504470299852E+13) X( 3) = ( 9.29199205117711E-01, 2.92018032584862E-01) X( 4) = ( -7.43231162629494E-01, 5.37610317571724E+00) X( 5) = ( -1.18263014978605E+01, 3.65733271271829E-01) X( 6) = ( -3.12002744590051E-01, -2.48586397262697E+00) X( 7) = ( -3.35047316302608E+13, -2.07843373536769E+13) X( 8) = ( -2.07843373536762E+13, 3.35047316302608E+13) X( 9) = ( 0.00000000000000E+00, -6.57807142090405E-15) PATH NUMBER = 64 ARCLEN = 1.08976878673627E+01 NFE = 209 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.62623473933996E-13 X( 1) = ( -3.99419270739346E+14, 1.24294800053068E+14) X( 2) = ( -1.24294800053061E+14, -3.99419270739350E+14) X( 3) = ( 5.49390527082427E-01, -6.87762907417054E-01) X( 4) = ( -3.84873013494921E+00, -2.46751182715445E+00) X( 5) = ( 1.17741508694963E+14, 4.47486849275668E+14) X( 6) = ( 4.47486849275666E+14, -1.17741508694966E+14) X( 7) = ( 7.16015227771497E+00, 2.03191155613228E+00) X( 8) = ( -3.13911653296876E+00, 3.29600781529598E+00) X( 9) = ( -4.44089209850063E-16, -2.27595720048157E-15) PATH NUMBER = 65 ARCLEN = 5.97481791502812E+00 NFE = 134 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.59548495453667E-17 X( 1) = ( -5.73993644466771E-01, -2.63874515550237E-01) X( 2) = ( -8.77471389081321E-01, 1.72612231859958E-01) X( 3) = ( -3.06129886067412E-01, 1.27633565998051E-01) X( 4) = ( 9.61367068432931E-01, 4.06425914724236E-02) X( 5) = ( 1.06286154111227E+00, 3.09983707316473E-02) X( 6) = ( -8.91250080067882E-02, 3.69671507746719E-01) X( 7) = ( 5.35586935983244E-01, 3.55587300380965E-02) X( 8) = ( -8.45528470021298E-01, 2.25241277423569E-02) X( 9) = ( 3.59803023977583E-01, -3.74310135504484E-01) PATH NUMBER = 66 ARCLEN = 4.88078843777574E+00 NFE = 132 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.16784730018751E-13 X( 1) = ( 1.09008912598853E+14, -8.77863337147233E+13) X( 2) = ( 8.77863337147232E+13, 1.09008912598853E+14) X( 3) = ( 8.60725076515929E-02, 1.84415087843615E-02) X( 4) = ( 3.82294272542755E-01, -3.36487752364482E+00) X( 5) = ( -3.88639872002905E+00, 3.61690471858092E+00) X( 6) = ( -8.37264093596687E-01, -1.54448988508499E+00) X( 7) = ( -9.94423370032271E+11, -8.31317887582108E+12) X( 8) = ( -8.31317887582116E+12, 9.94423370032293E+11) X( 9) = ( 1.88737914186277E-15, 4.85722573273506E-15) PATH NUMBER = 67 ARCLEN = 3.42900810153849E+01 NFE = 181 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.85953656073908E-16 X( 1) = ( 9.51044815428272E-01, -3.30314788813086E-03) X( 2) = ( -3.09237559760445E-01, -1.01586679057787E-02) X( 3) = ( -1.67483475490117E-01, -4.01571993917393E-02) X( 4) = ( 9.86715940318371E-01, -6.81621431787949E-03) X( 5) = ( 3.58070010433481E-01, 1.34366160073986E-01) X( 6) = ( -9.44687224087698E-01, 5.09295469577904E-02) X( 7) = ( 8.88159812042096E-01, -2.54383575921025E-02) X( 8) = ( -4.62819970372659E-01, -4.88166638087581E-02) X( 9) = ( -6.92023241527783E+00, -4.96211039848717E+00) PATH NUMBER = 68 ARCLEN = 8.24659672065997E+00 NFE = 176 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.45093405518266E-14 X( 1) = ( -8.28253379807935E-01, -5.66208311141472E-01) X( 2) = ( -9.39953195542942E-01, 4.98922658704705E-01) X( 3) = ( -2.88293160145086E-01, 1.92429259310048E-01) X( 4) = ( 9.78330979423583E-01, 5.67047762338639E-02) X( 5) = ( 1.28667055008929E+00, -7.48750669668272E-02) X( 6) = ( 1.18237411569357E-01, 8.14797468275654E-01) X( 7) = ( 4.88755859727676E-01, -1.68192955396118E-01) X( 8) = ( -8.93239162923569E-01, -9.20305511971847E-02) X( 9) = ( 3.19766856587105E-01, -3.37430147043440E-01) PATH NUMBER = 69 ARCLEN = 1.30033854403342E+02 NFE = 251 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.17411607684637E-13 X( 1) = ( 1.16805813859713E+00, -2.64606830344751E-01) X( 2) = ( 4.41763649679264E-01, 6.99641452928469E-01) X( 3) = ( 2.18650479698306E+00, -2.11047855621049E+00) X( 4) = ( -2.22789002770864E+00, -2.07127435811122E+00) X( 5) = ( 1.11182382946581E+00, 1.91784047471487E-01) X( 6) = ( 3.68368798447779E-01, -5.78849443787591E-01) X( 7) = ( -1.37945707030433E+00, 1.76735543503180E+00) X( 8) = ( 1.94659755754035E+00, 1.25243707470596E+00) X( 9) = ( 7.30263736401318E-02, 2.17927205311664E-01) PATH NUMBER = 70 ARCLEN = 1.36628673727645E+01 NFE = 117 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.28333349290716E-19 X( 1) = ( 1.32486380980226E+00, 1.59173912287481E-01) X( 2) = ( -2.37794058724457E-01, 8.86833577699620E-01) X( 3) = ( 2.96311243351956E+00, -1.56100702523029E+00) X( 4) = ( -1.63399050229238E+00, -2.83076267504741E+00) X( 5) = ( 9.91495870569986E-01, -1.35486485840606E-01) X( 6) = ( 3.91324176491087E-01, 3.43281349068547E-01) X( 7) = ( 6.78575243485810E-02, -2.51310594170734E+00) X( 8) = ( 2.70463905111499E+00, 6.30520910210430E-02) X( 9) = ( -9.25508488102489E-02, 1.00680275168447E-01) PATH NUMBER = 71 ARCLEN = 8.55761185887743E+01 NFE = 372 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 8.56869240855828E-14 X( 1) = ( -4.18058147158508E-01, 1.73228047118956E+00) X( 2) = ( -7.21112490716014E-01, -3.51166382638300E-01) X( 3) = ( 8.30074980483367E+13, -7.72888697574579E+12) X( 4) = ( -7.72888697574558E+12, -8.30074980483369E+13) X( 5) = ( -2.70034336983573E+15, -8.28831195952124E+14) X( 6) = ( 8.28831195952124E+14, -2.70034336983573E+15) X( 7) = ( -3.24747463570413E-01, -2.69198806362093E-01) X( 8) = ( -9.53506375091018E-02, 3.38108589532522E-02) X( 9) = ( -1.11022302462516E-16, 9.43689570931383E-16) PATH NUMBER = 72 ARCLEN = 1.98407578132420E+01 NFE = 178 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.61143588675338E-13 X( 1) = ( 3.06218970886339E+00, 1.46554887466193E+00) X( 2) = ( -2.34378562398332E+00, -1.89248352210161E+00) X( 3) = ( -1.32950624228073E+14, 7.35752605927568E+13) X( 4) = ( -7.35752605927566E+13, -1.32950624228073E+14) X( 5) = ( -4.84579502305342E+15, 5.14221856533738E+14) X( 6) = ( -5.14221856533738E+14, -4.84579502305342E+15) X( 7) = ( -4.75054833186364E-01, -1.08216184323068E+00) X( 8) = ( 2.01589098978281E-01, 6.80323387228032E-01) X( 9) = ( -2.22044604925031E-16, 4.71844785465692E-16) PATH NUMBER = 73 ARCLEN = 8.87991939383628E+00 NFE = 154 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 7.81478767592218E-12 X( 1) = ( -1.80098883472071E+00, 1.32330197022407E+01) X( 2) = ( 5.72613367197096E+00, -9.35154407100930E+00) X( 3) = ( 2.51261024040919E+12, -8.30316382453630E+12) X( 4) = ( 8.30316382453690E+12, 2.51261024040840E+12) X( 5) = ( 7.67586751660997E+13, -3.46257429721658E+13) X( 6) = ( -3.46257429721655E+13, -7.67586751661004E+13) X( 7) = ( -2.32954095899509E+00, 1.41897672412837E+00) X( 8) = ( -1.84393106065121E-01, -6.78046580827702E-01) X( 9) = ( -3.55271367880050E-15, 2.05391259555654E-14) PATH NUMBER = 74 ARCLEN = 1.52254497376947E+01 NFE = 140 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.76002578779467E-17 X( 1) = ( -1.17580884606015E+00, 3.91945730962369E-01) X( 2) = ( 6.00333423168923E-01, 7.67662168813460E-01) X( 3) = ( -4.46316901221626E-01, -4.48073453470406E-02) X( 4) = ( -8.96273829690172E-01, 2.23126848790971E-02) X( 5) = ( -1.71041655462014E+00, -8.19910369153661E-01) X( 6) = ( 9.53617690809592E-01, -1.47059799982795E+00) X( 7) = ( -9.69616408977201E-01, -9.02774498392343E-03) X( 8) = ( -2.47341824528348E-01, 3.53900909769931E-02) X( 9) = ( -4.11133501166166E-01, 6.14213586075490E-01) PATH NUMBER = 75 ARCLEN = 5.38901277521736E+00 NFE = 149 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 7.47359040166729E-12 X( 1) = ( 4.33698895805906E+13, -1.21053857565412E+13) X( 2) = ( 1.21053857565382E+13, 4.33698895805885E+13) X( 3) = ( -3.85386460795569E-01, -1.17327159463085E+00) X( 4) = ( -9.35119316276121E-01, -3.84389084321122E+00) X( 5) = ( 1.14851918096952E+00, -1.22352589995116E+01) X( 6) = ( -1.88910803536901E+00, 8.05407743492730E-01) X( 7) = ( 2.78842181117391E+12, 1.59354633582538E+12) X( 8) = ( -1.59354633582375E+12, 2.78842181117453E+12) X( 9) = ( 9.99200722162641E-15, 9.54791801177635E-15) PATH NUMBER = 76 ARCLEN = 1.07871108060759E+01 NFE = 180 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.42038714802122E-13 X( 1) = ( -1.89669656127443E+14, 2.87254450125363E+14) X( 2) = ( 2.87254450125364E+14, 1.89669656127445E+14) X( 3) = ( -4.48360520546285E-01, -1.24675984989886E-01) X( 4) = ( 5.95496358485546E-01, 5.69892492864114E-02) X( 5) = ( 3.78059614645994E+00, -2.43366425615482E+00) X( 6) = ( -7.72505656825421E-01, -4.75893229805390E-01) X( 7) = ( 1.01126362237755E+14, -1.64745677445951E+14) X( 8) = ( 1.64745677445952E+14, 1.01126362237755E+14) X( 9) = ( -2.22044604925031E-16, 1.11022302462516E-15) PATH NUMBER = 77 ARCLEN = 2.89020360990098E+01 NFE = 107 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.72549688815065E-13 X( 1) = ( 8.82849248272059E-02, 2.09844535749609E-01) X( 2) = ( 1.01812160806673E+00, -1.81963617285379E-02) X( 3) = ( 6.08392880071458E-01, -1.71205029496389E-03) X( 4) = ( -7.93638933696649E-01, -1.31243461674222E-03) X( 5) = ( -4.22090915226064E-01, 5.75142790295816E-01) X( 6) = ( 1.09620780507551E+00, 2.21456685144838E-01) X( 7) = ( -9.54400887068444E-01, -2.08881184804534E-02) X( 8) = ( 3.06255751857024E-01, -6.50947408694684E-02) X( 9) = ( -4.00842983969764E-01, 9.43125127717934E-02) PATH NUMBER = 78 ARCLEN = 1.89290853291136E+01 NFE = 157 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.94920645007528E-16 X( 1) = ( -9.97032338354657E-01, 1.55206513131492E-15) X( 2) = ( -7.69838702264874E-02, -3.69833399464443E-15) X( 3) = ( -2.06407758039419E-02, -1.09493830299150E-15) X( 4) = ( 9.99786956493339E-01, -6.21251935720658E-17) X( 5) = ( 6.44732206382425E-01, 2.01401321545378E-15) X( 6) = ( 7.64408517779109E-01, -3.35607822947209E-15) X( 7) = ( 1.83959491902009E-01, 1.05349165729000E-15) X( 8) = ( -9.82933825513782E-01, 2.40250488648788E-16) X( 9) = ( 3.83710764462186E-01, -5.51922121778574E-01) PATH NUMBER = 79 ARCLEN = 8.31626086216744E+00 NFE = 123 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.40222273869905E-13 X( 1) = ( -8.45196877409694E-01, -7.92235415425926E-01) X( 2) = ( 1.12566385494444E+00, -5.94844452320439E-01) X( 3) = ( -3.54281084627029E-01, -8.41957515841773E-02) X( 4) = ( -9.39458343171689E-01, 3.17512345374181E-02) X( 5) = ( -1.16156403958381E+00, -1.51629198529710E+00) X( 6) = ( 1.72860198938108E+00, -1.01889865593693E+00) X( 7) = ( -9.87295286067396E-01, 5.58588121487170E-03) X( 8) = ( -1.62572967705564E-01, -3.39227011098226E-02) X( 9) = ( -3.50646165033749E-01, 1.11585574323347E-01) PATH NUMBER = 80 ARCLEN = 4.34979082340819E+01 NFE = 203 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.10886121464491E-14 X( 1) = ( 1.08707913283361E+00, -1.12206976693279E-01) X( 2) = ( 2.52695630148105E-01, 4.82706657214897E-01) X( 3) = ( -7.60926702188133E-01, -3.00226576434991E-01) X( 4) = ( 7.73530340563730E-01, -2.95334787449217E-01) X( 5) = ( 1.11306763775108E+00, 1.06662124290839E-01) X( 6) = ( -2.25085865185228E-01, 5.27452750639068E-01) X( 7) = ( 5.60758078600101E-01, 2.75952812846174E-01) X( 8) = ( -8.89908277794083E-01, 1.73886200384041E-01) X( 9) = ( 5.07835095785393E-01, 1.15753829448945E-01) PATH NUMBER = 81 ARCLEN = 2.64821865872389E+00 NFE = 83 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.18880413779375E-14 X( 1) = ( 1.32486380980223E+00, -1.59173912287501E-01) X( 2) = ( -2.37794058724469E-01, -8.86833577699599E-01) X( 3) = ( 2.96311243351946E+00, 1.56100702523021E+00) X( 4) = ( -1.63399050229222E+00, 2.83076267504734E+00) X( 5) = ( 9.91495870569903E-01, 1.35486485840732E-01) X( 6) = ( 3.91324176491040E-01, -3.43281349068557E-01) X( 7) = ( 6.78575243486875E-02, 2.51310594170724E+00) X( 8) = ( 2.70463905111487E+00, -6.30520910211512E-02) X( 9) = ( -1.84431833969050E-01, 6.60668629459615E-02) PATH NUMBER = 82 ARCLEN = 3.52468775483163E+01 NFE = 175 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.20771831731101E-15 X( 1) = ( -3.23572566938690E-01, 4.87957435161641E-15) X( 2) = ( -9.46203357595344E-01, 1.92983898746088E-16) X( 3) = ( -7.82982639239781E-01, -1.98864772640237E-15) X( 4) = ( -6.22043556874521E-01, 1.82295743925507E-15) X( 5) = ( -8.67196525522176E-01, 6.21677835678101E-15) X( 6) = ( -4.97966049166273E-01, -1.30472494308676E-15) X( 7) = ( 7.73321237566211E-01, 3.31209739001032E-15) X( 8) = ( 6.34014403250481E-01, -1.88832301351416E-15) X( 9) = ( -3.88658327849299E-01, 4.29551819655338E-01) PATH NUMBER = 83 ARCLEN = 6.50266405183767E+01 NFE = 303 IFLAG2 = 11 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.18663932179268E-14 X( 1) = ( -2.39351283588260E+15, 2.51784403185679E+14) X( 2) = ( -2.51784403185680E+14, -2.39351283588260E+15) X( 3) = ( 1.35565965750937E-01, -2.03598456538831E+00) X( 4) = ( -2.81917832218770E+00, 1.13648126113192E+00) X( 5) = ( -2.21454230264308E+15, -1.77639564122139E+15) X( 6) = ( 1.77639564122141E+15, -2.21454230264308E+15) X( 7) = ( 7.85986787062418E-01, -5.00820861375421E+00) X( 8) = ( -4.91161475517113E+00, 1.15607873480951E+00) X( 9) = ( -3.33066907387547E-16, -1.38777878078145E-16) PATH NUMBER = 84 ARCLEN = 8.72657660255087E+00 NFE = 186 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.58951539759261E-16 X( 1) = ( 8.86905474091763E-01, -7.50273222418065E-17) X( 2) = ( 4.61950949805351E-01, 7.71492894665231E-17) X( 3) = ( 6.98952745885602E-01, 8.51788821066102E-17) X( 4) = ( 7.15167853737133E-01, 3.90409710936049E-17) X( 5) = ( -1.60239444861387E-02, -2.04230614886520E-16) X( 6) = ( -9.99871608359346E-01, -1.36067133010562E-16) X( 7) = ( -6.88217284181033E-01, -6.96883773160952E-17) X( 8) = ( -7.25504631104780E-01, 0.00000000000000E+00) X( 9) = ( -3.15812137063886E-01, -4.05297462821970E-01) PATH NUMBER = 85 ARCLEN = 3.63267892887719E+01 NFE = 240 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.84522968052162E-13 X( 1) = ( -3.44604977553518E+14, 4.62017916365716E+14) X( 2) = ( 4.62017916365716E+14, 3.44604977553516E+14) X( 3) = ( 3.04471241424629E-02, 1.28658788753897E-01) X( 4) = ( -2.07233805636351E+00, 2.81995698975171E+00) X( 5) = ( -1.13472337850421E+01, 6.41459864677215E+00) X( 6) = ( -1.12724551575333E+00, -4.01843539409009E+00) X( 7) = ( -2.52563123252490E+14, -9.95164491424772E+13) X( 8) = ( -9.95164491424770E+13, 2.52563123252490E+14) X( 9) = ( 8.88178419700125E-16, 1.44328993201270E-15) PATH NUMBER = 86 ARCLEN = 4.76583654294445E+00 NFE = 114 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.12700100793724E-14 X( 1) = ( 4.77229881863338E-03, -2.06051853225595E-15) X( 2) = ( -9.99988612517156E-01, -3.58778904261845E-15) X( 3) = ( -7.94232615166545E-01, 4.57061679720818E-16) X( 4) = ( -6.07613818971978E-01, -1.64100571855188E-15) X( 5) = ( 9.97769920671560E-01, 1.07015688939594E-15) X( 6) = ( 6.67471752441140E-02, 3.50230940921205E-15) X( 7) = ( 9.52226100439734E-01, -1.09066160745848E-15) X( 8) = ( 3.05393931899998E-01, -1.58652393292026E-15) X( 9) = ( -1.53819231206681E-01, 6.94277230542370E-01) PATH NUMBER = 87 ARCLEN = 1.22350872477984E+01 NFE = 202 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.88987649071241E-14 X( 1) = ( 1.52882796872254E+00, 5.93006252708760E-01) X( 2) = ( -7.34212672558230E-01, 1.23479827937265E+00) X( 3) = ( -6.27822700511963E-01, -2.57790977457442E-01) X( 4) = ( 8.42157099175799E-01, -1.92181515531183E-01) X( 5) = ( 1.34052542652371E+00, 1.04876828069926E+00) X( 6) = ( -1.25119464901042E+00, 1.12364654685892E+00) X( 7) = ( 7.03035713465339E-01, -2.44536619572988E-01) X( 8) = ( -7.83389442654795E-01, -2.19454038373666E-01) X( 9) = ( 4.60653591050045E-01, -1.71942534352613E-01) PATH NUMBER = 88 ARCLEN = 2.68611057294038E+01 NFE = 208 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.61972663878971E-13 X( 1) = ( 2.57986739985376E+14, 1.71766810045105E+14) X( 2) = ( -1.71766810045105E+14, 2.57986739985375E+14) X( 3) = ( 9.00772947670561E-02, -5.22828782903239E-01) X( 4) = ( -8.86132949085023E-01, -3.82932531469228E+00) X( 5) = ( -6.54029777826501E+00, -5.01372787570337E+00) X( 6) = ( -1.08822231677284E+00, 2.22281539042927E+00) X( 7) = ( 4.21874282666234E+12, 2.17003469963549E+13) X( 8) = ( -2.17003469963549E+13, 4.21874282666250E+12) X( 9) = ( 1.99840144432528E-15, -1.94289029309402E-16) PATH NUMBER = 89 ARCLEN = 1.12452063697637E+01 NFE = 165 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 9.43812414393657E-14 X( 1) = ( -4.29189775738583E+00, 1.35497413173880E+01) X( 2) = ( 8.64489086541263E+00, -8.28684200306236E+00) X( 3) = ( 3.79492141608415E+14, 3.32698532545077E+14) X( 4) = ( -3.32698532545077E+14, 3.79492141608415E+14) X( 5) = ( 7.05846270260087E+15, 1.45646098584445E+16) X( 6) = ( -1.45646098584445E+16, 7.05846270260087E+15) X( 7) = ( 1.22331703956979E+00, -2.74060949174937E+00) X( 8) = ( -1.59380523678886E+00, 9.75400803178799E-01) X( 9) = ( -1.11022302462516E-16, -1.11022302462516E-16) PATH NUMBER = 90 ARCLEN = 2.87513315236804E+01 NFE = 168 IFLAG2 = 11 REAL, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.82447734083313E-16 X( 1) = ( -6.44884386482952E-01, -2.15505977442961E-16) X( 2) = ( 7.64280137168634E-01, 6.33145843739751E-17) X( 3) = ( 6.26491381419070E-01, 1.39808559620242E-16) X( 4) = ( 7.79428347577649E-01, 6.40799902485316E-17) X( 5) = ( -7.57037314113677E-01, -1.51082547746675E-16) X( 6) = ( 6.53371643890022E-01, 1.67500582955992E-16) X( 7) = ( -4.88045334896596E-01, 0.00000000000000E+00) X( 8) = ( -8.72818280677983E-01, -2.47810076470194E-16) X( 9) = ( -2.98921290384287E-01, -6.57895574633736E-01) PATH NUMBER = 91 ARCLEN = 9.19349885727033E+00 NFE = 121 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 1.23021491194422E-13 X( 1) = ( 4.43664019476913E-01, 7.66038594780282E-01) X( 2) = ( -1.35688105043191E+00, 5.37907754233979E-01) X( 3) = ( -1.88160550542394E+14, -1.01051437499420E+14) X( 4) = ( -1.01051437499419E+14, 1.88160550542394E+14) X( 5) = ( -4.08244523678432E+14, -1.68460316974556E+15) X( 6) = ( -1.68460316974556E+15, 4.08244523678432E+14) X( 7) = ( -1.88387159762486E-01, -7.70176722258540E-01) X( 8) = ( 4.16248445921501E-01, -1.24244670805642E-01) X( 9) = ( -7.77156117237610E-16, -8.32667268468867E-17) PATH NUMBER = 92 ARCLEN = 4.14196611013007E+00 NFE = 143 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 2.97397152238306E-18 X( 1) = ( -8.40062525275419E-01, 3.31061653116358E-01) X( 2) = ( 7.38680181298250E-01, 3.76499187848783E-01) X( 3) = ( 5.17100724931638E-01, 3.88067038518990E+00) X( 4) = ( 4.00539746007343E+00, -5.00998337719435E-01) X( 5) = ( -1.65699648586207E+00, -5.82716504385741E-02) X( 6) = ( -7.30400050240809E-02, 1.32195938335803E+00) X( 7) = ( 3.73775710005446E+00, 7.06361391302761E-01) X( 8) = ( -7.32043054625677E-01, 3.60662844741596E+00) X( 9) = ( 7.53453708599470E-02, 7.98822897214044E-02) PATH NUMBER = 93 ARCLEN = 2.14564532456859E+01 NFE = 192 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 4.73793060642606E-14 X( 1) = ( -3.59213282135408E-01, 1.75620811047259E-01) X( 2) = ( 9.51945474476283E-01, 6.62698963743439E-02) X( 3) = ( 1.07619680311176E+00, -3.86550605399091E-02) X( 4) = ( -1.01778566379975E-01, -4.08734904182384E-01) X( 5) = ( -1.33456507217685E+00, -6.81624099524745E-01) X( 6) = ( 8.74702052835709E-01, -1.03997894212166E+00) X( 7) = ( -1.07398005488249E+00, -6.47210247186672E-02) X( 8) = ( -1.65402932515423E-01, 4.20240975309951E-01) X( 9) = ( -6.21797923991053E-01, 2.45396199993080E-01) PATH NUMBER = 94 ARCLEN = 7.35225178113378E+00 NFE = 113 IFLAG2 = 11 COMPLEX, FINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 3.95341309798032E-17 X( 1) = ( -1.78654801865848E-02, 2.42461036816495E-01) X( 2) = ( 1.02882744214239E+00, 4.21031037065201E-03) X( 3) = ( -3.32182462985674E+00, -2.10811115213515E+00) X( 4) = ( -2.17826339358012E+00, 3.21484333266451E+00) X( 5) = ( 1.09509784985601E+00, 4.19501638508547E-02) X( 6) = ( 1.00815582087485E-01, -4.55678906801468E-01) X( 7) = ( 2.99182814752127E+00, 1.24565781632952E+00) X( 8) = ( 1.30852462014192E+00, -2.84808864862652E+00) X( 9) = ( -1.18967115439308E-01, 9.50913537135347E-02) PATH NUMBER = 95 ARCLEN = 1.62383492342522E+02 NFE = 495 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.17028949804327E-13 X( 1) = ( -1.03617282984599E+01, -3.34972421927597E+00) X( 2) = ( 1.00646877116624E+01, -2.69972240689490E-01) X( 3) = ( 7.15448009463698E+13, 9.26055820305168E+13) X( 4) = ( 9.26055820305162E+13, -7.15448009463696E+13) X( 5) = ( 8.63723023378983E+13, -9.53278951952062E+14) X( 6) = ( -9.53278951952063E+14, -8.63723023378992E+13) X( 7) = ( 6.14892181413081E-02, 5.91353946672767E+00) X( 8) = ( -1.43369031121600E+00, -1.19464098417152E+00) X( 9) = ( -1.44328993201270E-15, 4.99600361081320E-16) PATH NUMBER = 96 ARCLEN = 1.50010049226036E+02 NFE = 360 IFLAG2 = 21 COMPLEX, INFINITE SOLUTION LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.80109682761924E-13 X( 1) = ( -3.90039560194330E+01, 1.82278882947698E+01) X( 2) = ( 3.45252364156759E+01, -4.70839021041544E+00) X( 3) = ( -2.56990637499573E+14, -5.75080301012711E+13) X( 4) = ( 5.75080301012682E+13, -2.56990637499575E+14) X( 5) = ( -1.21985561015691E+15, -2.24643254426566E+15) X( 6) = ( -2.24643254426567E+15, 1.21985561015691E+15) X( 7) = ( -3.16160530035586E+00, 4.22374133354725E+00) X( 8) = ( -1.43110221168648E+00, -1.77976927022992E+00) X( 9) = ( -6.66133814775094E-16, -1.66533453693773E-16) Testing optional arguments. PATH NUMBER = 13 ARCLEN = 1.38345665839938E+01 NFE = 196 IFLAG2 = 11 LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 5.61544526558644E-13 X( 1) = ( 4.60199313710204E-01, -1.13593415213791E-12) X( 2) = ( 6.47310119284360E-01, -1.18130448910141E-12) X( 3) = ( 5.45451458629319E-01, -3.22154528361619E-12) X( 4) = ( -9.14959682718453E-01, 4.68952494893297E-13) X( 5) = ( 4.34051374223916E-01, 4.41135409257318E-14) X( 6) = ( 2.17701204577855E-01, -1.95471582414453E-12) X( 7) = ( 4.50168351613835E-01, 9.87866821608084E-12) X( 8) = ( 1.04963129540163E+00, 3.42535570774125E-12) X( 9) = ( -1.63223051866181E-01, 1.93784395129743E-01) Statistics for retracked path. PATH NUMBER = 13 ARCLEN = 1.38617859813775E+01 NFE = 278 IFLAG2 = 11 LAMBDA = 1.00000000000000E+00, ESTIMATED ERROR = 6.38655202147685E-18 X( 1) = ( 4.60199313710775E-01, -4.18932012591540E-17) X( 2) = ( 6.47310119280712E-01, 0.00000000000000E+00) X( 3) = ( 5.45451458619945E-01, -1.67572805036616E-16) X( 4) = ( -9.14959682710769E-01, 0.00000000000000E+00) X( 5) = ( 4.34051374225724E-01, 4.18932012591540E-17) X( 6) = ( 2.17701204575123E-01, -4.18932012591540E-17) X( 7) = ( 4.50168351633661E-01, 1.67572805036616E-16) X( 8) = ( 1.04963129539735E+00, -2.51359207554924E-16) X( 9) = ( -1.63223051865496E-01, 1.93784395129652E-01) SHAR_EOF fi # end of overwriting check if test -f 'main_template.f90' then echo shar: will not over-write existing file "'main_template.f90'" else cat << SHAR_EOF > 'main_template.f90' ! This file contains a sample main program and user written subroutine ! for the POLSYS_PLP package. Layne T. Watson, Steven M. Wise, Andrew ! J. Sommese, August, 1998. Cosmetic changes, 10/1999. PROGRAM MAIN_TEMPLATE ! ! MAIN_TEMPLATE is a template for calling BEZOUT_PLP and POLSYS_PLP. ! There are two options provided by MAIN_TEMPLATE: (1) MAIN_TEMPLATE ! returns only the generalized PLP Bezout number ("root count") of the ! target polynomial system based on a system partition provided by the ! user (calls BEZOUT_PLP) or (2) MAIN_TEMPLATE returns the root count, ! homotopy path tracking statistics, error flags, and the roots (calls ! POLSYS_PLP). For the first option set the logical switch ! ROOT_COUNT_ONLY = .TRUE., and for the second option set ROOT_COUNT_ONLY ! = .FALSE.. ! ! The file INPUT.DAT contains data for several sample target systems ! and system partitions. This main program illustrates how to find the ! root count for several different partitions for the same polynomial ! system, and also how to solve more than one polynomial system in the ! same run. The data is read in using NAMELISTs, which makes the data ! file INPUT.DAT self-explanatory. The problem definition is given in ! the NAMELIST /PROBLEM/ and the PLP system partition is defined in the ! NAMELIST /SYSPARTITION/. A new polynomial system definition is ! signalled by setting the variable NEW_PROBLEM=.TRUE. in the /PROBLEM/ ! namelist. Thus a data file describing several different polynomial ! systems to solve, and exploring different system partitions for the ! same polynomial system, might look like ! ! &PROBLEM NEW_PROBLEM=.TRUE. data / ! &SYSPARTITION ROOT_COUNT_ONLY=.FALSE. data / finds roots ! ! &PROBLEM NEW_PROBLEM=.TRUE. data / ! &SYSPARTITION ROOT_COUNT_ONLY=.TRUE. data / finds root count only ! &PROBLEM NEW_PROBLEM=.FALSE. / ! &SYSPARTITION ROOT_COUNT_ONLY=.TRUE. data / a different root count ! &PROBLEM NEW_PROBLEM=.FALSE. / ! &SYSPARTITION ROOT_COUNT_ONLY=.TRUE. data / another root count ! ! Note that static arrays are used below only to support NAMELIST input; ! the actual storage of the polynomial system and partition information ! in the data structures in the module GLOBAL_PLP is very compact. USE POLSYS ! Local variables. IMPLICIT NONE INTEGER, PARAMETER:: NN = 30, MMAXT = 50 INTEGER:: BPLP, I, IFLAG1, J, K, M, MAXT, N, NUMRR = 1 INTEGER, DIMENSION(NN):: NUM_TERMS, NUM_SETS INTEGER, DIMENSION(NN,NN):: NUM_INDICES INTEGER, DIMENSION(NN,NN,NN):: INDEX INTEGER, DIMENSION(NN,MMAXT,NN):: DEG INTEGER, DIMENSION(:), POINTER:: IFLAG2, NFE REAL (KIND=R8):: TRACKTOL, FINALTOL, SINGTOL REAL (KIND=R8), DIMENSION(8):: SSPAR REAL (KIND=R8), DIMENSION(NN):: SCALE_FACTORS REAL (KIND=R8), DIMENSION(:), POINTER:: ARCLEN, LAMBDA COMPLEX (KIND=R8), DIMENSION(NN,MMAXT):: COEF COMPLEX (KIND=R8), DIMENSION(:,:), POINTER:: ROOTS CHARACTER (LEN=80):: TITLE CHARACTER (LEN=80), DIMENSION(NN):: P LOGICAL:: NEW_PROBLEM, NO_SCALING, RECALL, ROOT_COUNT_ONLY, USER_F_DF NAMELIST /PROBLEM/ COEF, DEG, FINALTOL, NEW_PROBLEM, N, NUMRR, NUM_TERMS, & SINGTOL, SSPAR, TITLE, TRACKTOL NAMELIST /SYSPARTITION/ INDEX, NUM_INDICES, NUM_SETS, P, ROOT_COUNT_ONLY NULLIFY(IFLAG2, NFE, ARCLEN, LAMBDA, ROOTS) ! Disassociate pointers. ! MAIN_TEMPLATE reads the target polynomial system definition and the ! system partition specification from the file INPUT.DAT. OPEN (UNIT=3,FILE='INPUT.DAT',ACTION='READ',POSITION='REWIND', & DELIM='APOSTROPHE',STATUS='OLD') ! All output is to the file OUTPUT.DAT, which is overwritten. OPEN (UNIT=7,FILE='OUTPUT.DAT',ACTION='WRITE',STATUS='REPLACE',DELIM='NONE') SSPAR(1:8) = 0.0_R8 ; DEG = 0 ; COEF = (0.0_R8,0.0_R8) MAIN_LOOP: & DO READ (3,NML=PROBLEM,END=500) IF (NEW_PROBLEM) THEN WRITE (7,190) TITLE,TRACKTOL,FINALTOL,SINGTOL,SSPAR(5),N 190 FORMAT(///A80//'TRACKTOL, FINALTOL =',2ES22.14, & /,'SINGTOL (0 SETS DEFAULT) =',ES22.14, & /,'SSPAR(5) (0 SETS DEFAULT) =',ES22.14, & /,'NUMBER OF EQUATIONS =',I3) WRITE (7,200) 200 FORMAT(/'****** COEFFICIENT TABLEAU ******') DO I=1,N WRITE (7,210) I,NUM_TERMS(I) 210 FORMAT(/,'POLYNOMIAL(',I2,')%NUM_TERMS =',I3) DO J=1,NUM_TERMS(I) WRITE (7,220) (I,J,K,DEG(I,J,K), K=1,N) 220 FORMAT('POLYNOMIAL(',I2,')%TERM(',I2,')%DEG(',I2,') =',I2) WRITE (7,230) I,J,COEF(I,J) 230 FORMAT('POLYNOMIAL(',I2,')%TERM(',I2,')%COEF = (',ES22.14, & ',',ES22.14,')') END DO END DO ! Allocate storage for the target system in POLYNOMIAL. CALL CLEANUP_POL ALLOCATE(POLYNOMIAL(N)) DO I=1,N POLYNOMIAL(I)%NUM_TERMS = NUM_TERMS(I) ALLOCATE(POLYNOMIAL(I)%TERM(NUM_TERMS(I))) DO J=1,NUM_TERMS(I) ALLOCATE(POLYNOMIAL(I)%TERM(J)%DEG(N+1)) POLYNOMIAL(I)%TERM(J)%COEF = COEF(I,J) POLYNOMIAL(I)%TERM(J)%DEG(1:N) = DEG(I,J,1:N) END DO END DO END IF READ (3,NML=SYSPARTITION) ! Allocate storage for the system partition in PARTITION. CALL CLEANUP_PAR ALLOCATE(PARTITION_SIZES(N)) PARTITION_SIZES(1:N) = NUM_SETS(1:N) ALLOCATE(PARTITION(N)) DO I=1,N ALLOCATE(PARTITION(I)%SET(PARTITION_SIZES(I))) DO J=1,PARTITION_SIZES(I) PARTITION(I)%SET(J)%NUM_INDICES = NUM_INDICES(I,J) ALLOCATE(PARTITION(I)%SET(J)%INDEX(NUM_INDICES(I,J))) PARTITION(I)%SET(J)%INDEX(1:NUM_INDICES(I,J)) = & INDEX(I,J,1:NUM_INDICES(I,J)) END DO END DO IF (ROOT_COUNT_ONLY) THEN ! Compute only the PLP Bezout number BPLP for this partition. MAXT = MAXVAL(NUM_TERMS(1:N)) CALL BEZOUT_PLP(N,MAXT,SINGTOL,BPLP) ELSE ! Compute all BPLP roots of the target polynomial system. CALL POLSYS_PLP(N,TRACKTOL,FINALTOL,SINGTOL,SSPAR,BPLP,IFLAG1,IFLAG2, & ARCLEN,LAMBDA,ROOTS,NFE,SCALE_FACTORS) END IF WRITE (7,240) BPLP, (K,TRIM(P(K)),K=1,N) 240 FORMAT(//,'GENERALIZED PLP BEZOUT NUMBER (BPLP) =',I10, & /'BASED ON THE FOLLOWING SYSTEM PARTITION:',/('P(',I2,') = ',A)) IF (.NOT. ROOT_COUNT_ONLY) THEN DO M=1,BPLP WRITE (7,260) M,ARCLEN(M),NFE(M),IFLAG2(M) 260 FORMAT(/'PATH NUMBER =',I10//'ARCLEN =',ES22.14/'NFE =',I5/ & 'IFLAG2 =',I3) ! Designate solutions as "REAL" or "COMPLEX." IF (ANY(ABS(AIMAG(ROOTS(1:N,M))) >= 1.0E-4_R8)) THEN WRITE (7,270,ADVANCE='NO') 270 FORMAT('COMPLEX, ') ELSE WRITE (7,280,ADVANCE='NO') 280 FORMAT('REAL, ') END IF ! Designate solutions as "FINITE" or "INFINITE." IF (ABS(ROOTS(N+1,M)) < 1.0E-6_R8) THEN WRITE (7,290) 290 FORMAT('INFINITE SOLUTION') ELSE WRITE (7,300) 300 FORMAT('FINITE SOLUTION') END IF IF (MOD(IFLAG2(M),10) == 1) THEN WRITE (7,310) 1.0_R8,LAMBDA(M) 310 FORMAT('LAMBDA =',ES22.14,', ESTIMATED ERROR =',ES22.14/) ELSE WRITE (7,315) LAMBDA(M) 315 FORMAT('LAMBDA =',ES22.14/) END IF WRITE (7,320) (J,ROOTS(J,M),J=1,N) 320 FORMAT(('X(',I2,') = (',ES22.14,',',ES22.14,')')) WRITE (7,330) N + 1, ROOTS(N+1,M) 330 FORMAT(/,'X(',I2,') = (',ES22.14,',',ES22.14,')') END DO END IF END DO MAIN_LOOP 500 CALL TEST_OPTIONS ! This tests various options, and is not part of a ! typical main program. CLOSE (UNIT=3) ; CLOSE (UNIT=7) CALL CLEANUP_POL CALL CLEANUP_PAR STOP CONTAINS SUBROUTINE CLEANUP_POL ! Deallocates structure POLYNOMIAL. IF (.NOT. ALLOCATED(POLYNOMIAL)) RETURN DO I=1,SIZE(POLYNOMIAL) DO J=1,NUMT(I) DEALLOCATE(POLYNOMIAL(I)%TERM(J)%DEG) END DO DEALLOCATE(POLYNOMIAL(I)%TERM) END DO DEALLOCATE(POLYNOMIAL) RETURN END SUBROUTINE CLEANUP_POL SUBROUTINE CLEANUP_PAR ! Deallocates structure PARTITION. IF (.NOT. ALLOCATED(PARTITION)) RETURN DO I=1,SIZE(PARTITION) DO J=1,PARTITION_SIZES(I) DEALLOCATE(PARTITION(I)%SET(J)%INDEX) END DO DEALLOCATE(PARTITION(I)%SET) END DO DEALLOCATE(PARTITION) DEALLOCATE(PARTITION_SIZES) RETURN END SUBROUTINE CLEANUP_PAR SUBROUTINE TEST_OPTIONS IMPLICIT NONE ! Illustrate use of optional arguments NUMRR, NO_SCALING, USER_F_DF: TRACKTOL = 1.0E-6_R8; FINALTOL = 1.0E-8_R8 CALL POLSYS_PLP(N,TRACKTOL,FINALTOL,SINGTOL,SSPAR,BPLP,IFLAG1,IFLAG2, & ARCLEN,LAMBDA,ROOTS,NFE,SCALE_FACTORS, NUMRR=1, NO_SCALING=.TRUE., & USER_F_DF=.TRUE.) M = 13 WRITE (7,FMT="(//'Testing optional arguments.')") WRITE (7,260) M,ARCLEN(M),NFE(M),IFLAG2(M) IF (MOD(IFLAG2(M),10) == 1) THEN WRITE (7,310) 1.0_R8,LAMBDA(M) ELSE WRITE (7,315) LAMBDA(M) END IF WRITE (7,320) (J,ROOTS(J,M),J=1,N) WRITE (7,330) N + 1, ROOTS(N+1,M) ! Now retrack one of these paths (#13) using the RECALL option: IFLAG2(13) = -2 TRACKTOL = 1.0E-10_R8; FINALTOL = 1.0E-14_R8 CALL POLSYS_PLP(N,TRACKTOL,FINALTOL,SINGTOL,SSPAR,BPLP,IFLAG1,IFLAG2, & ARCLEN,LAMBDA,ROOTS,NFE,SCALE_FACTORS, NUMRR=3, NO_SCALING=.TRUE., & USER_F_DF=.TRUE., RECALL=.TRUE.) M = 13 WRITE (7,FMT="(//'Statistics for retracked path.')") WRITE (7,260) M,ARCLEN(M),NFE(M),IFLAG2(M) IF (MOD(IFLAG2(M),10) == 1) THEN WRITE (7,310) 1.0_R8,LAMBDA(M) ELSE WRITE (7,315) LAMBDA(M) END IF WRITE (7,320) (J,ROOTS(J,M),J=1,N) WRITE (7,330) N + 1, ROOTS(N+1,M) RETURN 260 FORMAT(/'PATH NUMBER =',I10//'ARCLEN =',ES22.14/'NFE =',I5/ & 'IFLAG2 =',I3) 310 FORMAT('LAMBDA =',ES22.14,', ESTIMATED ERROR =',ES22.14/) 315 FORMAT('LAMBDA =',ES22.14/) 320 FORMAT(('X(',I2,') = (',ES22.14,',',ES22.14,')')) 330 FORMAT(/,'X(',I2,') = (',ES22.14,',',ES22.14,')') END SUBROUTINE TEST_OPTIONS END PROGRAM MAIN_TEMPLATE !!! SUBROUTINE TARGET_SYSTEM_USER(N,PROJ_COEF,XC,F,DF) ! Template for user written subroutine to evaluate the (complex) target ! system F(XC) and its (complex) N x N Jacobian matrix DF(XC). XC(1:N+1) ! is in complex projective coordinates, and the homogeneous coordinate ! XC(N+1) is explicitly eliminated from F(XC) and DF(XC) using the ! projective transformation (cf. the comments in START_POINTS_PLP). The ! comments in the internal subroutine TARGET_SYSTEM should be read before ! attempting to write this subroutine; pay particular attention to the ! handling of the homogeneous coordinate XC(N+1). DF(:,N+1) is not ! referenced by the calling program. USE REAL_PRECISION USE GLOBAL_PLP IMPLICIT NONE INTEGER, INTENT(IN):: N COMPLEX (KIND=R8), INTENT(IN), DIMENSION(N+1):: PROJ_COEF,XC COMPLEX (KIND=R8), INTENT(OUT):: F(N), DF(N,N+1) ! For greater efficiency, replace the following code (which is just the ! internal POLSYS_PLP subroutine TARGET_SYSTEM) with hand-crafted code. ! # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # INTEGER:: DEGREE, I, J, K, L COMPLEX (KIND=R8):: T, TS DO I=1,N TS = (0.0_R8, 0.0_R8) DO J=1,POLYNOMIAL(I)%NUM_TERMS T = POLYNOMIAL(I)%TERM(J)%COEF DO K=1,N+1 DEGREE = POLYNOMIAL(I)%TERM(J)%DEG(K) IF (DEGREE == 0) CYCLE T = T * XC(K)**DEGREE END DO TS = TS + T END DO F(I) = TS END DO DF = (0.0_R8,0.0_R8) DO I=1,N DO J=1,N+1 TS = (0.0_R8,0.0_R8) DO K=1,POLYNOMIAL(I)%NUM_TERMS DEGREE = POLYNOMIAL(I)%TERM(K)%DEG(J) IF (DEGREE == 0) CYCLE T = POLYNOMIAL(I)%TERM(K)%COEF * DEGREE * (XC(J)**(DEGREE - 1)) DO L=1,N+1 DEGREE = POLYNOMIAL(I)%TERM(K)%DEG(L) IF ((L == J) .OR. (DEGREE == 0)) CYCLE T = T * (XC(L)**DEGREE) END DO TS = TS + T END DO DF(I,J) = TS END DO END DO DO I=1,N DF(I,1:N) = DF(I,1:N) + PROJ_COEF(1:N) * DF(I,N+1) END DO ! # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # RETURN END SUBROUTINE TARGET_SYSTEM_USER SHAR_EOF fi # end of overwriting check if test -f 'test_install.f90' then echo shar: will not over-write existing file "'test_install.f90'" else cat << SHAR_EOF > 'test_install.f90' ! This file contains a main program to test the correctness of the ! compiled code; it is uncommented and has no further use beyond testing ! the installation. Author: Layne T. Watson, 10/1999. ! Compile this file (free form Fortran 90) and link it to the object ! files from the compiles of polsys_plp.f90 (free form) and lapack_plp.f ! (fixed format). Then run the executable with input file INPUT.DAT ! (upper case). A message indicating apparent success or failure of the ! installation is written to standard out. PROGRAM TEST_INSTALL USE POLSYS IMPLICIT NONE INTEGER, PARAMETER:: NN=30, MMAXT=50 INTEGER:: BPLP, I, IFLAG1, J, K, M, MAXT, N, NUMRR=1 INTEGER, DIMENSION(NN):: NUM_TERMS, NUM_SETS INTEGER, DIMENSION(NN,NN):: NUM_INDICES INTEGER, DIMENSION(NN,NN,NN):: INDEX INTEGER, DIMENSION(NN,MMAXT,NN):: DEG INTEGER, DIMENSION(:), POINTER:: IFLAG2, NFE REAL (KIND=R8):: TRACKTOL, FINALTOL, SINGTOL REAL (KIND=R8), DIMENSION(8):: SSPAR REAL (KIND=R8), DIMENSION(NN):: SCALE_FACTORS REAL (KIND=R8), DIMENSION(:), POINTER:: ARCLEN, LAMBDA COMPLEX (KIND=R8), DIMENSION(NN,MMAXT):: COEF COMPLEX (KIND=R8), DIMENSION(:,:), POINTER:: ROOTS COMPLEX (KIND=R8), DIMENSION(2,4):: EROOTS = RESHAPE(SOURCE=(/ & ( 2.34233851959121E+03_R8, 0.0E00_R8), & ( -7.88344824094120E-01_R8, 0.0E00_R8), & ( 9.08921229615388E-02_R8, 0.0E00_R8), & ( -9.11497098197499E-02_R8, 0.0E00_R8), & ( 1.61478579234357E-02_R8, 1.68496955498881E+00_R8), & ( 2.67994739614461E-04_R8, 4.42802993973661E-03_R8), & ( 1.61478579234359E-02_R8, -1.68496955498881E+00_R8), & ( 2.67994739614461E-04_R8, -4.42802993973661E-03_R8) /), & SHAPE=(/ 2,4 /) ) CHARACTER (LEN=80):: TITLE CHARACTER (LEN=80), DIMENSION(NN):: P LOGICAL:: NEW_PROBLEM, ROOT_COUNT_ONLY NAMELIST /PROBLEM/ COEF, DEG, FINALTOL, NEW_PROBLEM, N, NUMRR, NUM_TERMS, & SINGTOL, SSPAR, TITLE, TRACKTOL NAMELIST /SYSPARTITION/ INDEX, NUM_INDICES, NUM_SETS, P, ROOT_COUNT_ONLY NULLIFY(IFLAG2, NFE, ARCLEN, LAMBDA, ROOTS) ! Disassociate pointers. OPEN (UNIT=3,FILE='INPUT.DAT',ACTION='READ',POSITION='REWIND', & DELIM='APOSTROPHE',STATUS='OLD') SSPAR(1:8) = 0.0_R8 ; DEG = 0 ; COEF = (0.0_R8,0.0_R8) READ (3,NML=PROBLEM) CALL CLEANUP_POL ALLOCATE(POLYNOMIAL(N)) DO I=1,N POLYNOMIAL(I)%NUM_TERMS=NUM_TERMS(I) ALLOCATE(POLYNOMIAL(I)%TERM(NUM_TERMS(I))) DO J=1,NUM_TERMS(I) ALLOCATE(POLYNOMIAL(I)%TERM(J)%DEG(N+1)) POLYNOMIAL(I)%TERM(J)%COEF=COEF(I,J) POLYNOMIAL(I)%TERM(J)%DEG(1:N)=DEG(I,J,1:N) END DO END DO READ (3,NML=SYSPARTITION) CALL CLEANUP_PAR ALLOCATE(PARTITION_SIZES(N)) PARTITION_SIZES(1:N)=NUM_SETS(1:N) ALLOCATE(PARTITION(N)) DO I=1,N ALLOCATE(PARTITION(I)%SET(PARTITION_SIZES(I))) DO J=1,PARTITION_SIZES(I) PARTITION(I)%SET(J)%NUM_INDICES=NUM_INDICES(I,J) ALLOCATE(PARTITION(I)%SET(J)%INDEX(NUM_INDICES(I,J))) PARTITION(I)%SET(J)%INDEX(1:NUM_INDICES(I,J)) = & INDEX(I,J,1:NUM_INDICES(I,J)) END DO END DO CALL POLSYS_PLP(N,TRACKTOL,FINALTOL,SINGTOL,SSPAR,BPLP,IFLAG1,IFLAG2, & ARCLEN,LAMBDA,ROOTS,NFE,SCALE_FACTORS) SINGTOL = 0.0_R8 DO I=1,BPLP SINGTOL = MAX(SINGTOL, MINVAL(SUM(ABS(SPREAD( & EROOTS(1:2,I),DIM=2,NCOPIES=BPLP) - ROOTS(1:2,1:BPLP)), DIM=1))) END DO IF (SINGTOL < 1.0E-6_R8) THEN WRITE (*,*) 'Test problem was solved correctly. The installation ', & 'appears correct.' ELSE WRITE (*,*) 'Warning! Test problem was not solved correctly.' END IF CLOSE (UNIT=3) CALL CLEANUP_POL CALL CLEANUP_PAR STOP CONTAINS SUBROUTINE CLEANUP_POL ! Deallocates structure POLYNOMIAL. IF (.NOT. ALLOCATED(POLYNOMIAL)) RETURN DO I=1,SIZE(POLYNOMIAL) DO J=1,NUMT(I) DEALLOCATE(POLYNOMIAL(I)%TERM(J)%DEG) END DO DEALLOCATE(POLYNOMIAL(I)%TERM) END DO DEALLOCATE(POLYNOMIAL) RETURN END SUBROUTINE CLEANUP_POL SUBROUTINE CLEANUP_PAR ! Deallocates structure PARTITION. IF (.NOT. ALLOCATED(PARTITION)) RETURN DO I=1,SIZE(PARTITION) DO J=1,PARTITION_SIZES(I) DEALLOCATE(PARTITION(I)%SET(J)%INDEX) END DO DEALLOCATE(PARTITION(I)%SET) END DO DEALLOCATE(PARTITION) DEALLOCATE(PARTITION_SIZES) RETURN END SUBROUTINE CLEANUP_PAR END PROGRAM TEST_INSTALL !!! SUBROUTINE TARGET_SYSTEM_USER(N,PROJ_COEF,XC,F,DF) ! Template for user written subroutine to evaluate the (complex) target ! system F(XC) and its (complex) N x N Jacobian matrix DF(XC). XC(1:N+1) ! is in complex projective coordinates, and the homogeneous coordinate ! XC(N+1) is explicitly eliminated from F(XC) and DF(XC) using the ! projective transformation (cf. the comments in START_POINTS_PLP). The ! comments in the internal subroutine TARGET_SYSTEM should be read before ! attempting to write this subroutine; pay particular attention to the ! handling of the homogeneous coordinate XC(N+1). DF(:,N+1) is not ! referenced by the calling program. USE REAL_PRECISION USE GLOBAL_PLP IMPLICIT NONE INTEGER, INTENT(IN):: N COMPLEX (KIND=R8), INTENT(IN), DIMENSION(N+1):: PROJ_COEF,XC COMPLEX (KIND=R8), INTENT(OUT):: F(N), DF(N,N+1) ! For greater efficiency, replace the following code (which is just the ! internal POLSYS_PLP subroutine TARGET_SYSTEM) with hand-crafted code. ! # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # INTEGER:: DEGREE, I, J, K, L COMPLEX (KIND=R8):: T, TS DO I=1,N TS = (0.0_R8, 0.0_R8) DO J=1,POLYNOMIAL(I)%NUM_TERMS T = POLYNOMIAL(I)%TERM(J)%COEF DO K=1,N+1 DEGREE = POLYNOMIAL(I)%TERM(J)%DEG(K) IF (DEGREE == 0) CYCLE T = T * XC(K)**DEGREE END DO TS = TS + T END DO F(I)=TS END DO DF=(0.0_R8,0.0_R8) DO I=1,N DO J=1,N+1 TS = (0.0_R8,0.0_R8) DO K=1,POLYNOMIAL(I)%NUM_TERMS DEGREE = POLYNOMIAL(I)%TERM(K)%DEG(J) IF (DEGREE == 0) CYCLE T = POLYNOMIAL(I)%TERM(K)%COEF * DEGREE * (XC(J)**(DEGREE - 1)) DO L=1,N+1 DEGREE = POLYNOMIAL(I)%TERM(K)%DEG(L) IF ((L == J) .OR. (DEGREE == 0)) CYCLE T = T * (XC(L)**DEGREE) END DO TS = TS + T END DO DF(I,J) = TS END DO END DO DO I=1,N DF(I,1:N) = DF(I,1:N) + PROJ_COEF(1:N) * DF(I,N+1) END DO ! # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # RETURN END SUBROUTINE TARGET_SYSTEM_USER SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test -f 'lapack_plp.f' then echo shar: will not over-write existing file "'lapack_plp.f'" else cat << SHAR_EOF > 'lapack_plp.f' * This file contains the BLAS and LAPACK (double precision) routines * used by the POLSYS_PLP package. The file is in fixed source form. * SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DTRSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = X( J ) DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX + INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) DO 130, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX - INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of DTRSV . * END SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( LWORK ) * .. * * Purpose * ======= * * DORMQR overwrites the general real M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'T': Q**T * C C * Q**T * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**T from the Left; * = 'R': apply Q or Q**T from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'T': Transpose, apply Q**T. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * DGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, $ MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN INFO = -12 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMQR', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H' * CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, $ WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = IWS RETURN * * End of DORMQR * END SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) * .. * * Purpose * ======= * * DGEQRF computes a QR factorization of a real M-by-N matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(M,N)-by-N upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the orthogonal matrix Q as a * product of min(m,n) elementary reflectors (see Further * Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is * the optimal blocksize. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRF', -INFO ) RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size. * NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the QR factorization of the current block * A(i:m,i:i+ib-1) * CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i:m,i+ib:n) from the left * CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGEQRF * 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 modified to correct problem with negative increment, 8/21/90. 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 if(incx.lt.0)ix = (-n+1)*incx + 1 dmax = dabs(dx(ix)) 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 SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZTRSV solves one of the systems of equations * * A*x = b, or A'*x = b, or conjg( A' )*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' conjg( A' )*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = X( J ) IF( NOCONJ )THEN DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 100, I = 1, J - 1 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 100 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( J ) = TEMP 110 CONTINUE ELSE JX = KX DO 140, J = 1, N IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 120, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 130, I = 1, J - 1 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX + INCX 140 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) IF( NOCONJ )THEN DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 160, I = N, J + 1, -1 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 160 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( J ) = TEMP 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 180, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 180 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 190, I = N, J + 1, -1 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) IX = IX - INCX 190 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX - INCX 200 CONTINUE END IF END IF END IF * RETURN * * End of ZTRSV . * END SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * ZLARFX applies a complex elementary reflector H to a complex m by n * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a complex scalar and v is a complex vector. * * If tau = 0, then H is taken to be the unit matrix * * This version uses inline code if H has order < 11. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L' * or (N) if SIDE = 'R' * The vector v in the representation of H. * * TAU (input) COMPLEX*16 * The value tau in the representation of H. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L' * or (M) if SIDE = 'R' * WORK is not referenced if H has order < 11. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER J COMPLEX*16 SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZGERC * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * * w := C'*v * CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, 1, $ ZERO, WORK, 1 ) * * C := C - tau * v * w' * CALL ZGERC( M, N, -TAU, V, 1, WORK, 1, C, LDC ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) V9 = DCONJG( V( 9 ) ) T9 = TAU*DCONJG( V9 ) DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) V9 = DCONJG( V( 9 ) ) T9 = TAU*DCONJG( V9 ) V10 = DCONJG( V( 10 ) ) T10 = TAU*DCONJG( V10 ) DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * * w := C * v * CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, $ WORK, 1 ) * * C := C - tau * w * v' * CALL ZGERC( M, N, -TAU, WORK, 1, V, 1, C, LDC ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) V9 = V( 9 ) T9 = TAU*DCONJG( V9 ) DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) V9 = V( 9 ) T9 = TAU*DCONJG( V9 ) V10 = V( 10 ) T10 = TAU*DCONJG( V10 ) DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of ZLARFX * END SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INCX, N COMPLEX*16 ALPHA, TAU * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLARFG generates a complex elementary reflector H of order n, such * that * * H' * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, with beta real, and x is an * (n-1)-element complex vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a complex scalar and v is a complex (n-1)-element * vector. Note that H is not hermitian. * * If the elements of x are all zero and alpha is real, then tau = 0 * and H is taken to be the unit matrix. * * Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) COMPLEX*16 * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) COMPLEX*16 array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX <> 0. * * TAU (output) COMPLEX*16 * The value tau. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 COMPLEX*16 ZLADIV EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN * .. * .. External Subroutines .. EXTERNAL ZDSCAL, ZSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = DZNRM2( N-1, X, INCX ) ALPHR = DBLE( ALPHA ) ALPHI = DIMAG( ALPHA ) * IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) SAFMIN = DLAMCH( 'S' ) RSAFMN = ONE / SAFMIN * IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * KNT = 0 10 CONTINUE KNT = KNT + 1 CALL ZDSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHI = ALPHI*RSAFMN ALPHR = ALPHR*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DZNRM2( N-1, X, INCX ) ALPHA = DCMPLX( ALPHR, ALPHI ) BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of ZLARFG * END SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * -- LAPACK test routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQPF computes a QR factorization with column pivoting of a * real M-by-N matrix A: A*P = Q*R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0 * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the upper triangle of the array contains the * min(M,N)-by-N upper triangular matrix R; the elements * below the diagonal, together with the array TAU, * represent the orthogonal matrix Q as a product of * min(m,n) elementary reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted * to the front of A*P (a leading column); if JPVT(i) = 0, * the i-th column of A is a free column. * On exit, if JPVT(i) = k, then the i-th column of A*P * was the k-th column of A. * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors. * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(n) * * Each H(i) has the form * * H = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). * * The matrix P is represented in jpvt as follows: If * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT DOUBLE PRECISION AII, TEMP, TEMP2 * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DNRM2 EXTERNAL IDAMAX, DNRM2 * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQPF', -INFO ) RETURN END IF * MN = MIN( M, N ) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU, $ A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n entries of * work store the exact column norms. * DO 20 I = ITEMP + 1, N WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) WORK( N+I ) = WORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i) * IF( I.LT.M ) THEN CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) ELSE CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK( 2*N+1 ) ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = ONE + 0.05D0*TEMP* $ ( WORK( J ) / WORK( N+J ) )**2 IF( TEMP2.EQ.ONE ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = ZERO WORK( N+J ) = ZERO END IF ELSE WORK( J ) = WORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of DGEQPF * END double precision function dnrm2 ( n, dx, incx) integer i, incx, ix, j, n, 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 modified to correct problem with negative increment, 8/21/90. c modified to correct failure to update ix, 1/25/92. 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() real 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 i = 1 if( incx .lt. 0 )i = (-n+1)*incx + 1 ix = 1 c begin main loop 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 continue ix = 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 real 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 = ix,n if(dabs(dx(i)) .ge. hitest) go to 100 sum = sum + dx(i)**2 i = i + incx 95 continue dnrm2 = dsqrt( sum ) go to 300 c 200 continue ix = ix + 1 i = i + incx if( ix .le. n ) 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 DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * DLARFX applies a real elementary reflector H to a real m by n * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix * * This version uses inline code if H has order < 11. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' * or (N) if SIDE = 'R' * The vector v in the representation of H. * * TAU (input) DOUBLE PRECISION * The value tau in the representation of H. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= (1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * WORK is not referenced if H has order < 11. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER J DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * * w := C'*v * CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK, $ 1 ) * * C := C - tau * v * w' * CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * * w := C * v * CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, $ WORK, 1 ) * * C := C - tau * w * v' * CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of DLARFX * END SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLARFG generates a real elementary reflector H of order n, such * that * * H * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, and x is an (n-1)-element real * vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a real scalar and v is a real (n-1)-element * vector. * * If the elements of x are all zero, then tau = 0 and H is taken to be * the unit matrix. * * Otherwise 1 <= tau <= 2. * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) DOUBLE PRECISION * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) DOUBLE PRECISION array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX <> 0. * * TAU (output) DOUBLE PRECISION * The value tau. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = DNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * RSAFMN = ONE / SAFMIN KNT = 0 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of DLARFG * END SUBROUTINE XERBLA ( SRNAME, INFO ) * .. Scalar Arguments .. INTEGER INFO CHARACTER*6 SRNAME * .. * * Purpose * ======= * * XERBLA is an error handler for the Level 2 BLAS routines. * * It is called by the Level 2 BLAS routines if an input parameter is * invalid. * * Installers should consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Parameters * ========== * * SRNAME - CHARACTER*6. * On entry, SRNAME specifies the name of the routine which * called XERBLA. * * INFO - INTEGER. * On entry, INFO specifies the position of the invalid * parameter in the parameter-list of the calling routine. * * * Auxiliary routine for Level 2 Blas. * * Written on 20-July-1986. * * .. Executable Statements .. * WRITE (*,99999) SRNAME, INFO * STOP * 99999 FORMAT ( ' ** On entry to ', A6, ' parameter number ', I2, $ ' had an illegal value' ) * * End of XERBLA. * END LOGICAL FUNCTION LSAME ( CA, CB ) * .. Scalar Arguments .. CHARACTER*1 CA, CB * .. * * Purpose * ======= * * LSAME tests if CA is the same letter as CB regardless of case. * CB is assumed to be an upper case letter. LSAME returns .TRUE. if * CA is either the same as CB or the equivalent lower case letter. * * N.B. This version of the routine is only correct for ASCII code. * Installers must modify the routine for other character-codes. * * For EBCDIC systems the constant IOFF must be changed to -64. * For CDC systems using 6-12 bit representations, the system- * specific code in comments must be activated. * * Parameters * ========== * * CA - CHARACTER*1 * CB - CHARACTER*1 * On entry, CA and CB specify characters to be compared. * Unchanged on exit. * * * Auxiliary routine for Level 2 Blas. * * -- Written on 20-July-1986 * Richard Hanson, Sandia National Labs. * Jeremy Du Croz, Nag Central Office. * * .. Parameters .. INTEGER IOFF PARAMETER ( IOFF=32 ) * .. Intrinsic Functions .. INTRINSIC ICHAR * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA .EQ. CB * * Now test for equivalence * IF ( .NOT.LSAME ) THEN LSAME = ICHAR(CA) - IOFF .EQ. ICHAR(CB) END IF * RETURN * * The following comments contain code for CDC systems using 6-12 bit * representations. * * .. Parameters .. * INTEGER ICIRFX * PARAMETER ( ICIRFX=62 ) * .. Scalar Arguments .. * CHARACTER*1 CB * .. Array Arguments .. * CHARACTER*1 CA(*) * .. Local Scalars .. * INTEGER IVAL * .. Intrinsic Functions .. * INTRINSIC ICHAR, CHAR * .. Executable Statements .. * * See if the first character in string CA equals string CB. * * LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX) * * IF (LSAME) RETURN * * The characters are not identical. Now check them for equivalence. * Look for the 'escape' character, circumflex, followed by the * letter. * * IVAL = ICHAR(CA(2)) * IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN * LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB * END IF * * RETURN * * End of LSAME. * END SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. COMPLEX*16 ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * ZGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or * * y := alpha*conjg( A' )*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - COMPLEX*16 array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - COMPLEX*16 array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY LOGICAL NOCONJ * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGEMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = ZERO IF( NOCONJ )THEN DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = 1, M TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) 100 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 110 CONTINUE ELSE DO 140, J = 1, N TEMP = ZERO IX = KX IF( NOCONJ )THEN DO 120, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = 1, M TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 140 CONTINUE END IF END IF * RETURN * * End of ZGEMV . * END subroutine zscal(n,za,zx,incx) c c scales a vector by a constant. c jack dongarra, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c double complex za,zx(1) integer i,incx,ix,n c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n zx(ix) = za*zx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 do 30 i = 1,n zx(i) = za*zx(i) 30 continue return end subroutine zdscal(n,da,zx,incx) c c scales a vector by a constant. c jack dongarra, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c double complex zx(1) double precision da integer i,incx,ix,n c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n zx(ix) = dcmplx(da,0.0d0)*zx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 do 30 i = 1,n zx(i) = dcmplx(da,0.0d0)*zx(i) 30 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 SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * DGER performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of DGER . * END SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * DGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - DOUBLE PRECISION array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - DOUBLE PRECISION array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF END IF * RETURN * * End of DGEMV . * 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 modified to correct problem with negative increment, 8/21/90. c double precision da,dx(1) integer i,incx,ix,m,mp1,n c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n dx(ix) = da*dx(ix) ix = ix + incx 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 DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORM2R overwrites the general real m by n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'T', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'T', * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'T': apply Q' (Transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * DGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of DORM2R * END SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * Purpose * ======= * * DLARFT forms the triangular factor T of a real block reflector H * of order n, which is defined as a product of k elementary reflectors. * * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; * * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. * * If STOREV = 'C', the vector which defines the elementary reflector * H(i) is stored in the i-th column of the array V, and * * H = I - V * T * V' * * If STOREV = 'R', the vector which defines the elementary reflector * H(i) is stored in the i-th row of the array V, and * * H = I - V' * T * V * * Arguments * ========= * * DIRECT (input) CHARACTER*1 * Specifies the order in which the elementary reflectors are * multiplied to form the block reflector: * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Specifies how the vectors which define the elementary * reflectors are stored (see also Further Details): * = 'C': columnwise * = 'R': rowwise * * N (input) INTEGER * The order of the block reflector H. N >= 0. * * K (input) INTEGER * The order of the triangular factor T (= the number of * elementary reflectors). K >= 1. * * V (input/output) DOUBLE PRECISION array, dimension * (LDV,K) if STOREV = 'C' * (LDV,N) if STOREV = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i). * * T (output) DOUBLE PRECISION array, dimension (LDT,K) * The k by k triangular factor T of the block reflector. * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is * lower triangular. The rest of the array is not used. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * Further Details * =============== * * The shape of the matrix V and the storage of the vectors which define * the H(i) is best illustrated by the following example with n = 5 and * k = 3. The elements equal to 1 are not stored; the corresponding * array elements are modified but restored on exit. The rest of the * array is not used. * * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': * * V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) * ( v1 1 ) ( 1 v2 v2 v2 ) * ( v1 v2 1 ) ( 1 v3 v3 ) * ( v1 v2 v3 ) * ( v1 v2 v3 ) * * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': * * V = ( v1 v2 v3 ) V = ( v1 v1 1 ) * ( v1 v2 v3 ) ( v2 v2 v2 1 ) * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) * ( 1 v3 ) * ( 1 ) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION VII * .. * .. External Subroutines .. EXTERNAL DGEMV, DTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 I = 1, K IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 10 J = 1, I T( J, I ) = ZERO 10 CONTINUE ELSE * * general case * VII = V( I, I ) V( I, I ) = ONE IF( LSAME( STOREV, 'C' ) ) THEN * * T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) * CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, $ T( 1, I ), 1 ) ELSE * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' * CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, $ T( 1, I ), 1 ) END IF V( I, I ) = VII * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) END IF 20 CONTINUE ELSE DO 40 I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 30 J = I, K T( J, I ) = ZERO 30 CONTINUE ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN VII = V( N-K+I, I ) V( N-K+I, I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) * CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, $ T( I+1, I ), 1 ) V( N-K+I, I ) = VII ELSE VII = V( I, N-K+I ) V( I, N-K+I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' * CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, $ T( I+1, I ), 1 ) V( I, N-K+I ) = VII END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) END IF T( I, I ) = TAU( I ) END IF 40 CONTINUE END IF RETURN * * End of DLARFT * END SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * Purpose * ======= * * DLARFB applies a real block reflector H or its transpose H' to a * real m by n matrix C, from either the left or the right. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply H or H' from the Left * = 'R': apply H or H' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply H (No transpose) * = 'T': apply H' (Transpose) * * DIRECT (input) CHARACTER*1 * Indicates how H is formed from a product of elementary * reflectors * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Indicates how the vectors which define the elementary * reflectors are stored: * = 'C': Columnwise * = 'R': Rowwise * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * K (input) INTEGER * The order of the matrix T (= the number of elementary * reflectors whose product defines the block reflector). * * V (input) DOUBLE PRECISION array, dimension * (LDV,K) if STOREV = 'C' * (LDV,M) if STOREV = 'R' and SIDE = 'L' * (LDV,N) if STOREV = 'R' and SIDE = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); * if STOREV = 'R', LDV >= K. * * T (input) DOUBLE PRECISION array, dimension (LDT,K) * The triangular k by k matrix T in the representation of the * block reflector. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by H*C or H'*C or C*H or C*H'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) * * LDWORK (input) INTEGER * The leading dimension of the array WORK. * If SIDE = 'L', LDWORK >= max(1,N); * if SIDE = 'R', LDWORK >= max(1,M). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C1' * DO 10 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W' * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C2 := C2 - W * V2' * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C2' * DO 70 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W' * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C1 := C1 - W * V1' * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C1' * DO 130 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2' * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2' * W' * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2' * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C2' * DO 190 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1' * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1' * W' * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1' * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of DLARFB * END INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 20, 1992 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV is called from the LAPACK routines to choose problem-dependent * parameters for the local environment. See ISPEC for a description of * the parameters. * * This version provides a set of parameters which should give good, * but not optimal, performance on many of the currently available * computers. Users are encouraged to modify this subroutine to set * the tuning parameters for their particular machine using the option * and problem size information in the arguments. * * This routine will not function correctly if it is converted to all * lower case. Converting it to all upper case is allowed. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be returned as the value of * ILAENV. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or * lower case. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine NAME, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * N1 (input) INTEGER * N2 (input) INTEGER * N3 (input) INTEGER * N4 (input) INTEGER * Problem dimensions for the subroutine NAME; these may not all * be required. * * (ILAENV) (output) INTEGER * >= 0: the value of the parameter specified by ISPEC * < 0: if ILAENV = -k, the k-th argument had an illegal value. * * Further Details * =============== * * The following conventions have been used when calling ILAENV from the * LAPACK routines: * 1) OPTS is a concatenation of all of the character options to * subroutine NAME, in the same order that they appear in the * argument list for NAME, even if they are not used in determining * the value of the parameter specified by ISPEC. * 2) The problem dimensions N1, N2, N3, N4 are specified in the order * that they appear in the argument list for NAME. N1 is used * first, N2 second, and so on, and unused problem dimensions are * passed a value of -1. * 3) The parameter value returned by ILAENV is checked for validity in * the calling subroutine. For example, ILAENV is used to retrieve * the optimal blocksize for STRTRI as follows: * * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) * IF( NB.LE.1 ) NB = MAX( 1, N ) * * ===================================================================== * * .. Local Scalars .. LOGICAL CNAME, SNAME CHARACTER*1 C1 CHARACTER*2 C2, C4 CHARACTER*3 C3 CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. Executable Statements .. * GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * 100 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1:1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 10 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 10 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1:1 ) = CHAR( IC+64 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) $ SUBNAM( I:I ) = CHAR( IC+64 ) 20 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 30 CONTINUE END IF END IF * C1 = SUBNAM( 1:1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2:3 ) C3 = SUBNAM( 4:6 ) C4 = C3( 2:3 ) * GO TO ( 110, 200, 300 ) ISPEC * 110 CONTINUE * * ISPEC = 1: block size * * In these examples, separate code is provided for setting NB for * real and complex. We assume that NB will take the same value in * single or double precision. * NB = 1 * IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF END IF ILAENV = NB RETURN * 200 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF END IF ILAENV = NBMIN RETURN * 300 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF END IF ILAENV = NX RETURN * 400 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * 500 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * 600 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * 700 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * 800 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * * End of ILAENV * END SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQR2 computes a QR factorization of a real m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the orthogonal matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of DGEQR2 * END DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. COMPLEX*16 X, Y * .. * * Purpose * ======= * * ZLADIV := X / Y, where X and Y are complex. The computation of X / Y * will not overflow on an intermediary step unless the results * overflows. * * Arguments * ========= * * X (input) COMPLEX*16 * Y (input) COMPLEX*16 * The complex scalars X and Y. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION ZI, ZR * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DIMAG * .. * .. Executable Statements .. * CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, $ ZI ) ZLADIV = DCMPLX( ZR, ZI ) * RETURN * * End of ZLADIV * END DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z * .. * * Purpose * ======= * * DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause * unnecessary overflow. * * Arguments * ========= * * X (input) DOUBLE PRECISION * Y (input) DOUBLE PRECISION * Z (input) DOUBLE PRECISION * X, Y and Z specify the values x, y and z. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, ZABS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN DLAPY3 = ZERO ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) END IF RETURN * * End of DLAPY3 * END DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER CMACH * .. * * Purpose * ======= * * DLAMCH determines double precision machine parameters. * * Arguments * ========= * * CMACH (input) CHARACTER*1 * Specifies the value to be returned by DLAMCH: * = 'E' or 'e', DLAMCH := eps * = 'S' or 's , DLAMCH := sfmin * = 'B' or 'b', DLAMCH := base * = 'P' or 'p', DLAMCH := eps*base * = 'N' or 'n', DLAMCH := t * = 'R' or 'r', DLAMCH := rnd * = 'M' or 'm', DLAMCH := emin * = 'U' or 'u', DLAMCH := rmin * = 'L' or 'l', DLAMCH := emax * = 'O' or 'o', DLAMCH := rmax * * where * * eps = relative machine precision * sfmin = safe minimum, such that 1/sfmin does not overflow * base = base of the machine * prec = eps*base * t = number of (base) digits in the mantissa * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise * emin = minimum exponent before (gradual) underflow * rmin = underflow threshold - base**(emin-1) * emax = largest exponent before overflow * rmax = overflow threshold - (base**emax)*(1-eps) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL FIRST, LRND INTEGER BETA, IMAX, IMIN, IT DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, $ RND, SFMIN, SMALL, T * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAMC2 * .. * .. Save statement .. SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, $ EMAX, RMAX, PREC * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT IF( LRND ) THEN RND = ONE EPS = ( BASE**( 1-IT ) ) / 2 ELSE RND = ZERO EPS = BASE**( 1-IT ) END IF PREC = EPS*BASE EMIN = IMIN EMAX = IMAX SFMIN = RMIN SMALL = ONE / RMAX IF( SMALL.GE.SFMIN ) THEN * * Use SMALL plus a bit, to avoid the possibility of rounding * causing overflow when computing 1/sfmin. * SFMIN = SMALL*( ONE+EPS ) END IF END IF * IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = BASE ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = PREC ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = T ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = EMIN ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = RMIN ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = EMAX ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = RMAX END IF * DLAMCH = RMACH RETURN * * End of DLAMCH * END * ************************************************************************ * SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE1, RND INTEGER BETA, T * .. * * Purpose * ======= * * DLAMC1 determines the machine parameters given by BETA, T, RND, and * IEEE1. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * IEEE1 (output) LOGICAL * Specifies whether rounding appears to be done in the IEEE * 'round to nearest' style. * * Further Details * =============== * * The routine is based on the routine ENVRON by Malcolm and * incorporates suggestions by Gentleman and Marovich. See * * Malcolm M. A. (1972) Algorithms to reveal properties of * floating-point arithmetic. Comms. of the ACM, 15, 949-951. * * Gentleman W. M. and Marovich S. B. (1974) More on algorithms * that reveal properties of floating point arithmetic units. * Comms. of the ACM, 17, 276-277. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, LIEEE1, LRND INTEGER LBETA, LT DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Save statement .. SAVE FIRST, LIEEE1, LBETA, LRND, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ONE = 1 * * LBETA, LIEEE1, LT and LRND are the local values of BETA, * IEEE1, T and RND. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * Compute a = 2.0**m with the smallest positive integer m such * that * * fl( a + 1.0 ) = a. * A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 10 CONTINUE IF( C.EQ.ONE ) THEN A = 2*A C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 10 END IF *+ END WHILE * * Now compute b = 2.0**m with the smallest positive integer m * such that * * fl( a + b ) .gt. a. * B = 1 C = DLAMC3( A, B ) * *+ WHILE( C.EQ.A )LOOP 20 CONTINUE IF( C.EQ.A ) THEN B = 2*B C = DLAMC3( A, B ) GO TO 20 END IF *+ END WHILE * * Now compute the base. a and c are neighbouring floating point * numbers in the interval ( beta**t, beta**( t + 1 ) ) and so * their difference is beta. Adding 0.25 to c is to ensure that it * is truncated to beta and not ( beta - 1 ). * QTR = ONE / 4 SAVEC = C C = DLAMC3( C, -A ) LBETA = C + QTR * * Now determine whether rounding or chopping occurs, by adding a * bit less than beta/2 and a bit more than beta/2 to a. * B = LBETA F = DLAMC3( B / 2, -B / 100 ) C = DLAMC3( F, A ) IF( C.EQ.A ) THEN LRND = .TRUE. ELSE LRND = .FALSE. END IF F = DLAMC3( B / 2, B / 100 ) C = DLAMC3( F, A ) IF( ( LRND ) .AND. ( C.EQ.A ) ) $ LRND = .FALSE. * * Try and decide whether rounding is done in the IEEE 'round to * nearest' style. B/2 is half a unit in the last place of the two * numbers A and SAVEC. Furthermore, A is even, i.e. has last bit * zero, and SAVEC is odd. Thus adding B/2 to A should not change * A, but adding B/2 to SAVEC should change SAVEC. * T1 = DLAMC3( B / 2, A ) T2 = DLAMC3( B / 2, SAVEC ) LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND * * Now find the mantissa, t. It should be the integer part of * log to the base beta of a, however it is safer to determine t * by powering. So we find t as the smallest positive integer for * which * * fl( beta**t + 1.0 ) = 1.0. * LT = 0 A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 30 CONTINUE IF( C.EQ.ONE ) THEN LT = LT + 1 A = A*LBETA C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 30 END IF *+ END WHILE * END IF * BETA = LBETA T = LT RND = LRND IEEE1 = LIEEE1 RETURN * * End of DLAMC1 * END * ************************************************************************ * SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL RND INTEGER BETA, EMAX, EMIN, T DOUBLE PRECISION EPS, RMAX, RMIN * .. * * Purpose * ======= * * DLAMC2 determines the machine parameters specified in its argument * list. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * EPS (output) DOUBLE PRECISION * The smallest positive number such that * * fl( 1.0 - EPS ) .LT. 1.0, * * where fl denotes the computed value. * * EMIN (output) INTEGER * The minimum exponent before (gradual) underflow occurs. * * RMIN (output) DOUBLE PRECISION * The smallest normalized number for the machine, given by * BASE**( EMIN - 1 ), where BASE is the floating point value * of BETA. * * EMAX (output) INTEGER * The maximum exponent before overflow occurs. * * RMAX (output) DOUBLE PRECISION * The largest positive number for the machine, given by * BASE**EMAX * ( 1 - EPS ), where BASE is the floating point * value of BETA. * * Further Details * =============== * * The computation of EPS is based on a routine PARANOIA by * W. Kahan of the University of California at Berkeley. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, $ NGNMIN, NGPMIN DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, $ SIXTH, SMALL, THIRD, TWO, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. External Subroutines .. EXTERNAL DLAMC1, DLAMC4, DLAMC5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Save statement .. SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, $ LRMIN, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / , IWARN / .FALSE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 * * LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of * BETA, T, RND, EPS, EMIN and RMIN. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. * CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) * * Start to find EPS. * B = LBETA A = B**( -LT ) LEPS = A * * Try some tricks to see whether or not this is the correct EPS. * B = TWO / 3 HALF = ONE / 2 SIXTH = DLAMC3( B, -HALF ) THIRD = DLAMC3( SIXTH, SIXTH ) B = DLAMC3( THIRD, -HALF ) B = DLAMC3( B, SIXTH ) B = ABS( B ) IF( B.LT.LEPS ) $ B = LEPS * LEPS = 1 * *+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP 10 CONTINUE IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN LEPS = B C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) C = DLAMC3( HALF, -C ) B = DLAMC3( HALF, C ) C = DLAMC3( HALF, -B ) B = DLAMC3( HALF, C ) GO TO 10 END IF *+ END WHILE * IF( A.LT.LEPS ) $ LEPS = A * * Computation of EPS complete. * * Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). * Keep dividing A by BETA until (gradual) underflow occurs. This * is detected when we cannot recover the previous A. * RBASE = ONE / LBETA SMALL = ONE DO 20 I = 1, 3 SMALL = DLAMC3( SMALL*RBASE, ZERO ) 20 CONTINUE A = DLAMC3( ONE, SMALL ) CALL DLAMC4( NGPMIN, ONE, LBETA ) CALL DLAMC4( NGNMIN, -ONE, LBETA ) CALL DLAMC4( GPMIN, A, LBETA ) CALL DLAMC4( GNMIN, -A, LBETA ) IEEE = .FALSE. * IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN IF( NGPMIN.EQ.GPMIN ) THEN LEMIN = NGPMIN * ( Non twos-complement machines, no gradual underflow; * e.g., VAX ) ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN LEMIN = NGPMIN - 1 + LT IEEE = .TRUE. * ( Non twos-complement machines, with gradual underflow; * e.g., IEEE standard followers ) ELSE LEMIN = MIN( NGPMIN, GPMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) * ( Twos-complement machines, no gradual underflow; * e.g., CYBER 205 ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. $ ( GPMIN.EQ.GNMIN ) ) THEN IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT * ( Twos-complement machines with gradual underflow; * no known machine ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF *** * Comment out this if block if EMIN is ok IF( IWARN ) THEN FIRST = .TRUE. WRITE( 6, FMT = 9999 )LEMIN END IF *** * * Assume IEEE arithmetic if we found denormalised numbers above, * or if arithmetic seems to round in the IEEE style, determined * in routine DLAMC1. A true IEEE machine should have both things * true; however, faulty machines may have one or the other. * IEEE = IEEE .OR. LIEEE1 * * Compute RMIN by successive division by BETA. We could compute * RMIN as BASE**( EMIN - 1 ), but some machines underflow during * this computation. * LRMIN = 1 DO 30 I = 1, 1 - LEMIN LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) 30 CONTINUE * * Finally, call DLAMC5 to compute EMAX and RMAX. * CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) END IF * BETA = LBETA T = LT RND = LRND EPS = LEPS EMIN = LEMIN RMIN = LRMIN EMAX = LEMAX RMAX = LRMAX * RETURN * 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', $ ' EMIN = ', I8, / $ ' If, after inspection, the value EMIN looks', $ ' acceptable please comment out ', $ / ' the IF block as marked within the code of routine', $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) * * End of DLAMC2 * END * ************************************************************************ * DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B * .. * * Purpose * ======= * * DLAMC3 is intended to force A and B to be stored prior to doing * the addition of A and B , for use in situations where optimizers * might hold one of these in a register. * * Arguments * ========= * * A, B (input) DOUBLE PRECISION * The values A and B. * * ===================================================================== * * .. Executable Statements .. * DLAMC3 = A + B * RETURN * * End of DLAMC3 * END * ************************************************************************ * SUBROUTINE DLAMC4( EMIN, START, BASE ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER BASE, EMIN DOUBLE PRECISION START * .. * * Purpose * ======= * * DLAMC4 is a service routine for DLAMC2. * * Arguments * ========= * * EMIN (output) EMIN * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered. * * START (input) DOUBLE PRECISION * The starting point for determining EMIN. * * BASE (input) INTEGER * The base of the machine. * * ===================================================================== * * .. Local Scalars .. INTEGER I DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Executable Statements .. * A = START ONE = 1 RBASE = ONE / BASE ZERO = 0 EMIN = 1 B1 = DLAMC3( A*RBASE, ZERO ) C1 = A C2 = A D1 = A D2 = A *+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. * $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP 10 CONTINUE IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. $ ( D2.EQ.A ) ) THEN EMIN = EMIN - 1 A = B1 B1 = DLAMC3( A / BASE, ZERO ) C1 = DLAMC3( B1*BASE, ZERO ) D1 = ZERO DO 20 I = 1, BASE D1 = D1 + B1 20 CONTINUE B2 = DLAMC3( A*RBASE, ZERO ) C2 = DLAMC3( B2 / RBASE, ZERO ) D2 = ZERO DO 30 I = 1, BASE D2 = D2 + B2 30 CONTINUE GO TO 10 END IF *+ END WHILE * RETURN * * End of DLAMC4 * END * ************************************************************************ * SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER BETA, EMAX, EMIN, P DOUBLE PRECISION RMAX * .. * * Purpose * ======= * * DLAMC5 attempts to compute RMAX, the largest machine floating-point * number, without overflow. It assumes that EMAX + abs(EMIN) sum * approximately to a power of 2. It will fail on machines where this * assumption does not hold, for example, the Cyber 205 (EMIN = -28625, * EMAX = 28718). It will also fail if the value supplied for EMIN is * too large (i.e. too close to zero), probably with overflow. * * Arguments * ========= * * BETA (input) INTEGER * The base of floating-point arithmetic. * * P (input) INTEGER * The number of base BETA digits in the mantissa of a * floating-point value. * * EMIN (input) INTEGER * The minimum exponent before (gradual) underflow. * * IEEE (input) LOGICAL * A logical flag specifying whether or not the arithmetic * system is thought to comply with the IEEE standard. * * EMAX (output) INTEGER * The largest exponent before overflow * * RMAX (output) DOUBLE PRECISION * The largest machine floating-point number. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP DOUBLE PRECISION OLDY, RECBAS, Y, Z * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * First compute LEXP and UEXP, two powers of 2 that bound * abs(EMIN). We then assume that EMAX + abs(EMIN) will sum * approximately to the bound that is closest to abs(EMIN). * (EMAX is the exponent of the required number RMAX). * LEXP = 1 EXBITS = 1 10 CONTINUE TRY = LEXP*2 IF( TRY.LE.( -EMIN ) ) THEN LEXP = TRY EXBITS = EXBITS + 1 GO TO 10 END IF IF( LEXP.EQ.-EMIN ) THEN UEXP = LEXP ELSE UEXP = TRY EXBITS = EXBITS + 1 END IF * * Now -LEXP is less than or equal to EMIN, and -UEXP is greater * than or equal to EMIN. EXBITS is the number of bits needed to * store the exponent. * IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN EXPSUM = 2*LEXP ELSE EXPSUM = 2*UEXP END IF * * EXPSUM is the exponent range, approximately equal to * EMAX - EMIN + 1 . * EMAX = EXPSUM + EMIN - 1 NBITS = 1 + EXBITS + P * * NBITS is the total number of bits needed to store a * floating-point number. * IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN * * Either there are an odd number of bits used to store a * floating-point number, which is unlikely, or some bits are * not used in the representation of numbers, which is possible, * (e.g. Cray machines) or the mantissa has an implicit bit, * (e.g. IEEE machines, Dec Vax machines), which is perhaps the * most likely. We have to assume the last alternative. * If this is true, then we need to reduce EMAX by one because * there must be some way of representing zero in an implicit-bit * system. On machines like Cray, we are reducing EMAX by one * unnecessarily. * EMAX = EMAX - 1 END IF * IF( IEEE ) THEN * * Assume we are on an IEEE machine which reserves one exponent * for infinity and NaN. * EMAX = EMAX - 1 END IF * * Now create RMAX, the largest machine number, which should * be equal to (1.0 - BETA**(-P)) * BETA**EMAX . * * First compute 1.0 - BETA**(-P), being careful that the * result is less than 1.0 . * RECBAS = ONE / BETA Z = BETA - ONE Y = ZERO DO 20 I = 1, P Z = Z*RECBAS IF( Y.LT.ONE ) $ OLDY = Y Y = DLAMC3( Y, Z ) 20 CONTINUE IF( Y.GE.ONE ) $ Y = OLDY * * Now multiply by BETA**EMAX to get RMAX. * DO 30 I = 1, EMAX Y = DLAMC3( Y*BETA, ZERO ) 30 CONTINUE * RMAX = Y RETURN * * End of DLAMC5 * END SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * DLARF applies a real elementary reflector H to a real m by n matrix * C, from either the left or the right. H is represented in the form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) DOUBLE PRECISION array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) DOUBLE PRECISION * The value tau in the representation of H. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, $ WORK, 1 ) * * C := C - v * w' * CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of DLARF * END DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y * .. * * Purpose * ======= * * DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary * overflow. * * Arguments * ========= * * X (input) DOUBLE PRECISION * Y (input) DOUBLE PRECISION * X and Y specify the values x and y. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN * * End of DLAPY2 * END SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. COMPLEX*16 ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * ZGERC performs the rank 1 operation * * A := alpha*x*conjg( y' ) + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGERC ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( Y( JY ) ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( Y( JY ) ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of ZGERC . * END double precision function dznrm2( n, zx, incx) logical imag, scale integer i, incx, ix, n, next double precision cutlo, cuthi, hitest, sum, xmax, absx, zero, one double complex zx(1) double precision dreal,dimag double complex zdumr,zdumi dreal(zdumr) = zdumr dimag(zdumi) = (0.0d0,-1.0d0)*zdumi data zero, one /0.0d0, 1.0d0/ c c unitary norm of the complex n-vector stored in zx() 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 modified to correct problem with negative increment, 8/21/90. c c four phase method using two built-in constants that are c hopefully applicable to all machines. c cutlo = maximum of sqrt(u/eps) over all known machines. c cuthi = minimum of sqrt(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() real 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 dznrm2 = zero go to 300 c 10 assign 30 to next sum = zero i = 1 if( incx .lt. 0 )i = (-n+1)*incx + 1 c begin main loop do 220 ix = 1,n absx = dabs(dreal(zx(i))) imag = .false. go to next,(30, 50, 70, 90, 110) 30 if( absx .gt. cutlo) go to 85 assign 50 to next scale = .false. c c phase 1. sum is zero c 50 if( absx .eq. zero) go to 200 if( absx .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 assign 110 to next sum = (sum / absx) / absx 105 scale = .true. xmax = absx go to 115 c c phase 2. sum is small. c scale to avoid destructive underflow. c 70 if( absx .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( absx .le. xmax ) go to 115 sum = one + sum * (xmax / absx)**2 xmax = absx go to 200 c 115 sum = sum + (absx/xmax)**2 go to 200 c c c prepare for phase 3. c 75 sum = (sum * xmax) * xmax c 85 assign 90 to next scale = .false. c c for real or d.p. set hitest = cuthi/n c for complex set hitest = cuthi/(2*n) c hitest = cuthi/dble( 2*n ) c c phase 3. sum is mid-range. no scaling. c 90 if(absx .ge. hitest) go to 100 sum = sum + absx**2 200 continue c control selection of real and imaginary parts. c if(imag) go to 210 absx = dabs(dimag(zx(i))) imag = .true. go to next,( 50, 70, 90, 110 ) c 210 continue i = i + incx 220 continue c c end of main loop. c compute square root and adjust for scaling. c dznrm2 = dsqrt(sum) if(scale) dznrm2 = dznrm2 * xmax 300 continue return end SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DTRMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, * * where x is an n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' x := A*x. * * TRANS = 'T' or 't' x := A'*x. * * TRANS = 'C' or 'c' x := A'*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := A*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE * * Form x := A'*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 110, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = 1, N TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 130, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of DTRMV . * END SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DTRMM performs one of the matrix-matrix operations * * B := alpha*op( A )*B, or B := alpha*B*op( A ), * * where alpha is a scalar, B is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies B from * the left or right as follows: * * SIDE = 'L' or 'l' B := alpha*op( A )*B. * * SIDE = 'R' or 'r' B := alpha*B*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B, and on exit is overwritten by the * transformed matrix. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) * INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*A*B. * IF( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) B( K, J ) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP IF( NOUNIT ) $ B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF( UPPER )THEN DO 110, J = 1, N DO 100, I = M, 1, -1 TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE B( I, J ) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140, J = 1, N DO 130, I = 1, M TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 120, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 120 CONTINUE B( I, J ) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*A. * IF( UPPER )THEN DO 180, J = N, 1, -1 TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = 1, M B( I, J ) = TEMP*B( I, J ) 150 CONTINUE DO 170, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 160, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE ELSE DO 220, J = 1, N TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 190, I = 1, M B( I, J ) = TEMP*B( I, J ) 190 CONTINUE DO 210, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 200, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 200 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF( UPPER )THEN DO 260, K = 1, N DO 240, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 230, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 230 CONTINUE END IF 240 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 250, I = 1, M B( I, K ) = TEMP*B( I, K ) 250 CONTINUE END IF 260 CONTINUE ELSE DO 300, K = N, 1, -1 DO 280, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 270, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 270 CONTINUE END IF 280 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE END IF 300 CONTINUE END IF END IF END IF * RETURN * * End of DTRMM . * END SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X', * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = A'. * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = B'. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * transposed and set NROWA, NCOLA and NROWB as the number of rows * and columns of A and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And if alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN * * Form C := alpha*A*B' + beta*C * DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF * RETURN * * End of DGEMM . * 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 SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * Purpose * ======= * * DLADIV performs complex division in real arithmetic * * a + i*b * p + i*q = --------- * c + i*d * * The algorithm is due to Robert L. Smith and can be found * in D. Knuth, The art of Computer Programming, Vol.2, p.195 * * Arguments * ========= * * A (input) DOUBLE PRECISION * B (input) DOUBLE PRECISION * C (input) DOUBLE PRECISION * D (input) DOUBLE PRECISION * The scalars a, b, c, and d in the above expression. * * P (output) DOUBLE PRECISION * Q (output) DOUBLE PRECISION * The scalars p and q in the above expression. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION E, F * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( ABS( D ).LT.ABS( C ) ) THEN E = D / C F = C + D*E P = ( A+B*E ) / F Q = ( B-A*E ) / F ELSE E = C / D F = D + C*E P = ( B+A*E ) / F Q = ( -A+B*E ) / F END IF * RETURN * * End of DLADIV * END SHAR_EOF fi # end of overwriting check if test -f 'polsys_plp.f90' then echo shar: will not over-write existing file "'polsys_plp.f90'" else cat << SHAR_EOF > 'polsys_plp.f90' ! This file contains all the modules and external subroutines for the ! package POLSYS_PLP, except for the LAPACK routines used, which are ! distributed in a separate file. Layne T. Watson, Steven M. Wise, Andrew ! J. Sommese, August, 1998. Cosmetic changes, 10/1999. MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic. INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13) END MODULE REAL_PRECISION !!! MODULE GLOBAL_PLP ! The module GLOBAL_PLP contains derived data types, arrays, and ! functions used in POLSYS_PLP and related subroutines. GLOBAL_PLP uses ! the HOMPACK90 module REAL_PRECISION for 64-bit arithmetic. USE REAL_PRECISION, ONLY: R8 IMPLICIT NONE INTEGER, PARAMETER:: LARGE=SELECTED_INT_KIND(15) REAL (KIND=R8), PARAMETER:: PI=3.1415926535897932384626433_R8 ! TARGET SYSTEM: Let X be a complex N-dimensional vector. POLSYS_PLP ! is used to solve the polynomial system, called the target system, ! F(X)=0, where F is represented by the following derived data types: TYPE TERM_TYPE COMPLEX (KIND=R8):: COEF INTEGER, DIMENSION(:), POINTER:: DEG END TYPE TERM_TYPE TYPE POLYNOMIAL_TYPE TYPE(TERM_TYPE), DIMENSION(:), POINTER:: TERM INTEGER:: NUM_TERMS END TYPE POLYNOMIAL_TYPE TYPE(POLYNOMIAL_TYPE), DIMENSION(:), ALLOCATABLE:: POLYNOMIAL ! The mathematical representation of the target system F is, for I=1,...,N, ! ! F_I(X) = SUM_{J=1}^{POLYNOMIAL(I)%NUM_TERMS} ! POLYNOMIAL(I)%TERM(J)%COEF * ! PRODUCT_{K=1}^N X(K)**POLYNOMIAL(I)%TERM(J)%DEG(K). ! ! Any program calling POLSYS_PLP (such as the sample main program ! MAIN_TEMPLATE) must aquire data and allocate storage for the target ! system as illustrated below: ! ! ALLOCATE(POLYNOMIAL(N)) ! DO I=1,N ! READ (*,*) POLYNOMIAL(I)%NUM_TERMS ! ALLOCATE(POLYNOMIAL(I)%TERM(POLYNOMIAL(I)%NUM_TERMS)) ! DO J=1,POLYNOMIAL(I)%NUM_TERMS ! ALLOCATE(POLYNOMIAL(I)%TERM(J)%DEG(N+1)) ! READ (*,*) POLYNOMIAL(I)%TERM(J)%COEF,POLYNOMIAL(I)%TERM(J)%DEG(1:N) ! END DO ! END DO ! ! START SYSTEM/PARTITION: In a partitioned linear product (PLP) ! formulation the start system G(X)=0 and the variable partition ! P have the same structure. G and P are represented by the derived data ! types: INTEGER, DIMENSION(:), ALLOCATABLE:: PARTITION_SIZES TYPE SET_TYPE INTEGER, DIMENSION(:), POINTER:: INDEX INTEGER:: NUM_INDICES INTEGER:: SET_DEG COMPLEX (KIND=R8), DIMENSION(:), POINTER:: START_COEF END TYPE SET_TYPE TYPE PARTITION_TYPE TYPE(SET_TYPE), DIMENSION(:), POINTER:: SET END TYPE PARTITION_TYPE TYPE(PARTITION_TYPE), DIMENSION(:), ALLOCATABLE:: PARTITION ! The mathematical representation of the start system G is, for I=1,...,N, ! ! G_I(X) = PRODUCT_{J=1}^{PARTITION_SIZES(I)} ! ( L(I,J)**PARTITION(I)SET(J)%SET_DEG - 1.0 ), ! ! where the linear factors L(I,J) are ! ! L(I,J) = SUM_{K=1}^{PARTITION(I)%SET(J)%NUM_INDICES} ! PARTITION(I)%SET(J)%START_COEF(K) * X(PARTITION(I)%SET(J)%INDEX(K)). ! ! The system partition P=(P(1),...,P(N)) is comprised of the component ! partitions P(I) = {S(I,1),...S(I, PARTITION_SIZES(I))}, where the sets ! of variables S(I,J) are defined by ! ! S(I,J) = UNION_{K=1}^{PARTITION(I)%SET(J)%NUM_INDICES} ! { X(PARTITION(I)%SET(J)%INDEX(K)) }. ! ! The calling program must acquire data and allocate storage as ! illustrated below: ! ! ALLOCATE(PARTITION_SIZES(N)) ! READ (*,*) PARTITION_SIZES(1:N) ! ALLOCATE(PARTITION(N)) ! DO I=1,N ! ALLOCATE(PARTITION(I)%SET(PARTITION_SIZES(I)) ! DO J=1, PARTITION_SIZES(I) ! READ (*,*) PARTITION(I)%SET(J)%NUM_INDICES ! ALLOCATE(PARTITION(I)%SET(J)%INDEX(PARTITION(I)%SET(J)%NUM_INDICES)) ! READ (*,*) PARTITION(I)%SET(J)%INDEX ! END DO ! END DO ! ! SET_DEG and START_COEF are calculated by POLSYS_PLP. CONTAINS ! INDEXING FUNCTIONS FOR THE TARGET SYSTEM: ! ! C(I,J) retrieves the coefficient of the Jth term of the Ith polynomial ! component of the target system. COMPLEX (KIND=R8) FUNCTION C(I,J) IMPLICIT NONE INTEGER:: I,J C = POLYNOMIAL(I)%TERM(J)%COEF END FUNCTION C ! D(I,J,K) retrieves the degree of the Kth variable in the Jth term of ! the Ith polynomial component of the target system. INTEGER FUNCTION D(I,J,K) IMPLICIT NONE INTEGER:: I,J,K D = POLYNOMIAL(I)%TERM(J)%DEG(K) END FUNCTION D ! NUMT(I) retrieves the number of terms in the Ith polynomial component of ! the target system F(X). INTEGER FUNCTION NUMT(I) IMPLICIT NONE INTEGER:: I NUMT = POLYNOMIAL(I)%NUM_TERMS END FUNCTION NUMT ! The target system is succinctly specified with the retrieval functions: ! ! F_I(X) = SUM_{J=1}^{NUMT(I)} C(I,J) * PRODUCT_{K=1}^N X(K)**D(I,J,K). ! ! INDEXING FUNCTIONS FOR THE START SYSTEM/PARTITION: ! ! PAR(I,J,K) retrieves the index of the Kth variable in the Jth set ! S(I,J) of the Ith partition P(I). INTEGER FUNCTION PAR(I,J,K) IMPLICIT NONE INTEGER:: I,J,K PAR = PARTITION(I)%SET(J)%INDEX(K) END FUNCTION PAR ! SC(I,J,K) retrieves the coefficient of the variable with index ! PAR(I,J,K) in the Jth factor of the Ith component of the start system ! G(X). COMPLEX (KIND=R8) FUNCTION SC(I,J,K) IMPLICIT NONE INTEGER:: I,J,K SC = PARTITION(I)%SET(J)%START_COEF(K) END FUNCTION SC ! SD(I,J) retrieves the set degree of the Jth set S(I,J) in the Ith ! partition P(I). INTEGER FUNCTION SD(I,J) IMPLICIT NONE INTEGER:: I,J SD = PARTITION(I)%SET(J)%SET_DEG END FUNCTION SD ! NUMV(I,J) retrieves the number of variables in the Jth set S(I,J) of ! the Ith partition P(I). INTEGER FUNCTION NUMV(I,J) IMPLICIT NONE INTEGER:: I,J NUMV = PARTITION(I)%SET(J)%NUM_INDICES END FUNCTION NUMV ! Both the start system and the partition are succinctly specified with ! retrieval functions: ! ! G_I(X) = PRODUCT_{J=1}^{PARTITION_SIZES(I)} ! ( [ SUM_{K=1}^{NUMV(I,J)} SC(I,J,K)*X(PAR(I,J,K)) ]**SD(I,J) - 1.0 ), ! ! and P(I) = { S(I,1),...,S(I,PARTITION_SIZES(I)) }, where ! ! S(I,J) = UNION_{K=1}^{NUMV(I,J)} { X(PAR(I,J,K)) }. END MODULE GLOBAL_PLP !!! MODULE POLSYS ! This module contains the subroutines POLSYS_PLP (finds all or some of ! the roots of a polynomial system defined in the module GLOBAL_PLP), ! BEZOUT_PLP (computes the generalized Bezout number), and SINGSYS_PLP ! (checks the nonsingularity of a generic start point). Typically a ! user would only call POLSYS_PLP, and thus include in their main ! program the statements: ! USE GLOBAL_PLP ! USE POLSYS, ONLY: POLSYS_PLP ! An expert user might want to call BEZOUT_PLP or SINGSYS_PLP ! separately, and thus these routines are also provided as module ! procedures. USE GLOBAL_PLP CONTAINS !!! SUBROUTINE POLSYS_PLP(N,TRACKTOL,FINALTOL,SINGTOL,SSPAR,BPLP,IFLAG1, & IFLAG2,ARCLEN,LAMBDA,ROOTS,NFE,SCALE_FACTORS, & NUMRR,RECALL,NO_SCALING,USER_F_DF) ! Using a probability-one globally convergent homotopy method, ! POLSYS_PLP finds all finite isolated complex solutions to a system ! F(X) = 0 of N polynomial equations in N unknowns with complex ! coefficients. A partitioned linear product (PLP) formulation is used ! for the start system of the homotopy map. ! ! POLSYS_PLP uses the module GLOBAL_PLP, which contains the definition ! of the polynomial system to be solved, and also defines the notation ! used below. The user may also find it beneficial at some point to ! refer to the documentation for STEPNX in the HOMPACK90 package. ! ! The representation of F(X) is stored in the module GLOBAL_PLP. Using ! the same notation as GLOBAL_PLP, F(X) is defined mathematically by ! ! F_I(X)=SUM_{J=1}^{NUMT(I)} C(I,J) * PRODUCT_{K=1}^N X(K)**D(I,J,K), ! ! for I=1,...,N. ! ! POLSYS_PLP features target system scaling, a projective ! transformation so that the homotopy zero curves are tracked in complex ! projective space, and a partitioned linear product (PLP) formulation of ! the start system. Scaling may be disabled by the optional argument ! NO_SCALING. Whatever the case, the roots of F(X) are always returned ! unscaled and untransformed. The PLP partition (an m-homogeneous ! partition of the variables, possibly different for each component ! F_I(X)) is defined in the module GLOBAL_PLP. ! ! Scaling is carried out in the internal subroutine SCALE_PLP, and is ! an independent preprocessing step. SCALE_PLP modifies the polynomial ! coefficients and creates and stores unscaling factors SCALE_FACTORS ! for the variables X(I). The problem is solved with the scaled ! coefficients and scaled variables. The coefficients of the target ! polynomial system, which are contained in the global structure ! POLYNOMIAL, remain in modified form on return from POLSYS_PLP. ! ! With the projective transformation, the system is essentially recast in ! homogeneous coordinates, Z(1),...,Z(N+1), and solved in complex ! projective space. The resulting solutions are untransformed via ! X(I) = Z(I)/Z(N+1), I=1,...N, unless this division would cause ! overflow, in which case Re(X(I)) = Im(X(I)) = HUGE(1.0_R8). ! On return, for the Jth path, ROOTS(I,J) = X(I) for I=1,...,N, and ! ROOTS(N+1,J) = Z(N+1), the homogeneous variable. ! ! In the PLP scheme the number of paths that must be tracked can be ! less, and commonly far less, than the "total degree" because of the ! specialized start system G(X) = 0. The structure of the start system ! is determined by the system partition P. The representations of both ! are stored in the module GLOBAL_PLP, and following the comments there, ! are defined mathematically as follows: ! ! The system partition P=(P(1),...,P(N)) is comprised of the component ! partitions P(I)={S(I,1),...,S(I,PARTITION_SIZES(I))}, where the sets of ! variables S(I,J) are defined by ! ! S(I,J) = UNION_{K=1}^{NUMV(I,J)} {X(PAR(I,J,K))}. ! ! The only restriction on the system partition P is that each component ! partition P(I) should be a partition of the set {X(1),...,X(N)}, that ! is, the three following properties should hold for each I=1,...,N: ! ! i) each set S(I,J) has cardinality NUMV(I,J) > 0, ! ! ii) S(I,J1) INTERSECTION S(I,J2) = { }, for J1 /= J2, and ! ! iii) UNION_{J=1}^{PARTITION_SIZES(I)} S(I,J) = {X(1),...,X(N)}. ! ! The start system is defined mathematically, for I=1,...,N, by ! ! G_I(X) = PRODUCT_{J=1}^{PARTITION_SIZES(I)} ( L(I,J)**SD(I,J)-1.0 ), ! ! where the linear factors L(I,J) are ! ! L(I,J) = SUM{K=1}^{NUMV(I,J)} SC(I,J,K)*X(PAR(I,J,K)). ! ! Contained in this module (POLSYS) is the routine BEZOUT_PLP. This ! routine calculates the generalized PLP Bezout number, based on the ! system partition P provided by the user, by counting the number of ! solutions to the start system. The user is encouraged to explore ! several system partitions with BEZOUT_PLP before calling POLSYS_PLP. ! See the sample calling program MAIN_TEMPLATE and the comments in ! BEZOUT_PLP. ! ! Internal routines: INIT_PLP, INTERP, OUTPUT_PLP, RHO, ROOT_OF_UNITY, ! ROOT_PLP, SCALE_PLP, START_POINTS_PLP, START_SYSTEM, TANGENT_PLP, ! TARGET_SYSTEM. ! ! External routines called: BEZOUT_PLP, SINGSYS_PLP, STEPNX. ! ! ! On input: ! ! N is the dimension of the target polynomial system. ! ! TRACKTOL is the local error tolerance allowed the path tracker along ! the path. ABSERR and RELERR (of STEPNX) are set to TRACKTOL. ! ! FINALTOL is the accuracy desired for the final solution. It is used ! for both the absolute and relative errors in a mixed error criterion. ! ! SINGTOL is the singularity test threshold used by SINGSYS_PLP. If ! SINGTOL <= 0.0 on input, then SINGTOL is reset to a default value. ! ! SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P) is a ! vector of parameters used for the optimal step size estimation. If ! SSPAR(I) <= 0.0 on input, it is reset to a default value by STEPNX. ! See the comments in STEPNX for more information. ! ! Optional arguments: ! ! NUMRR is the number of multiples of 1000 steps that will be tried before ! abandoning a path. If absent, NUMRR is taken as 1. ! ! RECALL is used to retrack certain homotopy paths. It's use assumes ! BPLP contains the Bezout number (which is not recalculated), ! SCALE_FACTORS contains the variable unscaling factors, and that ! IFLAG2(1:BPLP) exists. The Ith homotopy path is retracked if ! IFLAG2(I) = -2, and skipped otherwise. ! ! NO_SCALING indicates that the target polynomial is not to be scaled. ! Scaling is done by default when NO_SCALING is absent. ! ! USER_F_DF indicates (when present) that the user is providing a subroutine ! TARGET_SYSTEM_USER to evaluate the (complex) target system F(XC) and ! its (complex) N x N Jacobian matrix DF(XC). XC(1:N+1) is in ! complex projective coordinates, and the homogeneous coordinate XC(N+1) ! is explicitly eliminated from F(XC) and DF(XC) using the projective ! transformation (cf. the comments in START_POINTS_PLP). ! ! ! The following objects must be allocated and defined as described in ! GLOBAL_PLP: ! ! POLYNOMIAL(I)%NUM_TERMS is the number of terms in the Ith component ! F_I(X) of the target polynomial system, for I=1,...,N. ! ! POLYNOMIAL(I)%TERM(J)%COEF is the coefficient of the Jth term in the Ith ! component of the target polynomial system, for J=1,...,NUMT(I), and ! I=1,...,N. ! ! POLYNOMIAL(I)%TERM(J)%DEG(K) is the degree of the Kth variable in the ! Jth term of the Ith component of the target polynomial system, for ! K=1,...,N, J=1,...NUMT(I), and I=1,...,N. ! ! PARTITION_SIZES(I) is the number of sets in the Ith component ! partition P(I), for I=1,...,N. ! ! PARTITION(I)%SET(J)%NUM_INDICES is the number of indices stored in the ! Jth set S(I,J) of the Ith component partition P(I), for ! J=1,...,PARTITION_SIZES(I), and I=1,...,N. ! ! PARTITION(I)SET(J)%INDEX(K) is the index of the Kth variable stored ! in the Jth set S(I,J) of the Ith component partition P(I). ! ! ! On output: ! ! BPLP is the generalized Bezout number corresponding to the ! partitioned linear product (PLP) formulation defined by the system ! partition P. This is the number of paths tracked and the number of ! roots returned (counting multiplicity). ! ! IFLAG1 ! = 0 for a normal return. ! ! = -1 if either POLYNOMIAL or PARTITION was improperly allocated. ! ! = -2 if any POLYNOMIAL(I)%TERM(J)%DEG(K) is less than zero. ! ! = -3 if F_I(X) = CONSTANT for some I. ! ! = -4 if SUM_{J=1}^{PARTITION_SIZES(I)} ! PARTITION(I)SET(J)%NUM_INDICES /= N, for some I. ! ! = -5 if UNION_{J=1}^{PARTITION_SIZES} ! S(I,J) /= {1,2,...,N-1,N}, for some I. ! ! = -6 if the optional argument RECALL was present but any of BPLP ! or the arrays ARCLEN, IFLAG2, LAMBDA, NFE, ROOTS are ! inconsistent with the previous call to POLSYS_PLP. ! ! = -7 if the array SCALE_FACTORS is too small. ! ! IFLAG2(1:BPLP) is an integer array which returns information about ! each path tracked. Precisely, for each path I that was tracked, ! IFLAG2(I): ! = 1 + 10*C, where C is the cycle number of the path, for a normal return. ! ! = 2 if the specified error tolerance could not be met. Increase ! TRACKTOL and rerun. ! ! = 3 if the maximum number of steps allowed was exceeded. To track ! the path further, increase NUMRR and rerun the path. ! ! = 4 if the Jacobian matrix does not have full rank. The algorithm has ! failed (the zero curve of the homotopy map cannot be followed any ! further). ! ! = 5 if the tracking algorithm has lost the zero curve of the homotopy ! map and is not making progress. The error tolerances TRACKTOL and ! FINALTOL were too lenient. The problem should be restarted with ! smaller error tolerances. ! ! = 6 if the normal flow Newton iteration in STEPNX or ROOT_PLP failed ! to converge. The error error tolerances TRACKTOL or FINALTOL may ! be too stringent. ! ! = 7 if ROOT_PLP failed to find a root in 10*NUMRR iterations. ! ! ARCLEN(I) is the approximate arc length of the Ith path, for I=1,...,BPLP. ! ! LAMBDA(I), if MOD(IFLAG2(I),10) = 1, contains an error estimate of ! the normalized residual of the scaled, transformed polynomial ! system of equations at the scaled, transformed root for the Ith path ! (LAMBDA for this path is assumed to be 1). Otherwise LAMBDA(I) is the ! final value of the homotopy parameter lambda on the Ith path, for ! I=1,...,BPLP. ! ! ROOTS(1:N,I) are the complex roots (untransformed and unscaled) of ! the target polynomial corresonding to the Ith path, for I=1,...,BPLP. ! ! ROOTS(N+1,I) is the homogeneous variable of the target polynomial ! system in complex projective space corresponding to ROOTS(1:N,I). ! ! NFE(I) is the number of Jacobian matrix evaluations required to track ! the Ith path, for I=1,...,BPLP. ! ! SCALE_FACTORS(1:N) contains the unscaling factors for the variables X(I). ! These are needed only on a recall when scaling was done on the original ! call to POLSYS_PLP (NO_SCALING was absent). USE GLOBAL_PLP IMPLICIT NONE INTEGER, INTENT(IN):: N REAL (KIND=R8), INTENT(IN):: TRACKTOL, FINALTOL REAL (KIND=R8), INTENT(IN OUT):: SINGTOL REAL (KIND=R8), DIMENSION(8), INTENT(IN OUT):: SSPAR INTEGER, INTENT(IN OUT):: BPLP, IFLAG1 INTEGER, DIMENSION(:), POINTER:: IFLAG2 REAL (KIND=R8), DIMENSION(:), POINTER:: ARCLEN, LAMBDA COMPLEX (KIND=R8), DIMENSION(:,:), POINTER:: ROOTS INTEGER, DIMENSION(:), POINTER:: NFE REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: SCALE_FACTORS INTEGER, OPTIONAL, INTENT(IN):: NUMRR LOGICAL, OPTIONAL, INTENT(IN):: RECALL, NO_SCALING, USER_F_DF INTERFACE SUBROUTINE STEPNX(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR, & ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR) USE REAL_PRECISION INTEGER, INTENT(IN):: N INTEGER, INTENT(IN OUT):: NFE,IFLAG LOGICAL, INTENT(IN OUT):: START,CRASH REAL (KIND=R8), INTENT(IN OUT):: HOLD,H,RELERR,ABSERR,S,RHOLEN, & SSPAR(8) REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD, & TZ,W,WP REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: Z0,Z1 END SUBROUTINE STEPNX END INTERFACE ! Local variables. INTEGER:: BTEMP, I, IFLAG, II, ITER, J, JJ, K, KK, LIMIT, MAXPS, & MAXT, NNFE, NUM_RERUNS, ROOT_COUNT INTEGER, SAVE:: BPLP_SAVE INTEGER, DIMENSION(N):: CHECK_PAR, DLEX_NUM, DLEX_SAVE, FLEX_NUM, FLEX_SAVE INTEGER, DIMENSION(2*N+1):: PIVOT REAL (KIND=R8):: ABSERR, H, HOLD, RELERR, RHOLEN, S REAL (KIND=R8), DIMENSION(2*N):: A, DRHOL, RHOV, Z REAL (KIND=R8), DIMENSION(2*N+1):: Y, YP, YOLD, YOLDS, YPOLD, TZ, W, WP REAL (KIND=R8), DIMENSION(3*(2*N+1)):: ALPHA REAL (KIND=R8), DIMENSION(2*N+1,12):: YS REAL (KIND=R8), DIMENSION(N,N):: RAND_MAT REAL, DIMENSION(N,N):: RANDNUMS REAL (KIND=R8), DIMENSION(N+1,N):: MAT REAL (KIND=R8), DIMENSION(2*N,2*N):: DRHOX REAL (KIND=R8), DIMENSION(2*N,2*N+2):: QR COMPLEX (KIND=R8), DIMENSION(N-1):: TAU COMPLEX (KIND=R8), DIMENSION(N):: B, F, G, V COMPLEX (KIND=R8), DIMENSION(N+1):: PROJ_COEF, XC COMPLEX (KIND=R8), DIMENSION(N,N):: AA COMPLEX (KIND=R8), DIMENSION(N,N+1):: DF, DG COMPLEX (KIND=R8), DIMENSION(:,:), ALLOCATABLE:: TEMP1G, TEMP2G LOGICAL:: CRASH, NONSING, START ! Begin input data check. IFLAG1 = 0 ! Normal return. ! Check that dimensions are valid. IF ((N <= 0) .OR. (SIZE(POLYNOMIAL) /= N) & .OR. ANY((/(NUMT(I),I=1,N)/) <= 0) & .OR. (SIZE(PARTITION) /= N) & .OR. ANY(PARTITION_SIZES <= 0)) THEN IFLAG1 = -1 RETURN END IF DO I=1,N IF ((SIZE(POLYNOMIAL(I)%TERM) /= NUMT(I)) & .OR. (SIZE(PARTITION(I)%SET) /= PARTITION_SIZES(I)) & .OR. ANY((/(NUMV(I,J),J=1,PARTITION_SIZES(I))/) <= 0)) THEN IFLAG1 = -1 RETURN END IF END DO DO I=1,N DO J=1,NUMT(I) IF (SIZE(POLYNOMIAL(I)%TERM(J)%DEG) /= N + 1) THEN IFLAG1 = -1 RETURN END IF END DO DO J=1,PARTITION_SIZES(I) IF (SIZE(PARTITION(I)%SET(J)%INDEX) /= NUMV(I,J)) THEN IFLAG1 = -1 RETURN END IF END DO END DO ! Check that the target system has no negative powers. DO I=1,N DO J=1,NUMT(I) IF (ANY(POLYNOMIAL(I)%TERM(J)%DEG(1:N) < 0)) THEN IFLAG1 = -2 RETURN END IF END DO END DO ! Check that the target system has no constant-valued components. DO I=1,N IF (ALL( (/( SUM(POLYNOMIAL(I)%TERM(J)%DEG(1:N)), & J=1,NUMT(I) )/) == 0)) THEN IFLAG1 = -3 RETURN END IF END DO ! Check that the system partition is valid. DO I=1,N IF (SUM( (/(NUMV(I,J),J=1,PARTITION_SIZES(I))/) ) /= N) THEN IFLAG1 = -4 RETURN END IF CHECK_PAR(1:N) = 0 DO J=1,PARTITION_SIZES(I) DO K=1,NUMV(I,J) CHECK_PAR(PAR(I,J,K)) = CHECK_PAR(PAR(I,J,K)) + 1 END DO END DO IF (ANY(CHECK_PAR /= 1)) THEN IFLAG1 = -5 RETURN END IF END DO ! Check consistency on a recall. IF (PRESENT(RECALL)) THEN IF ( (BPLP /= BPLP_SAVE) .OR. (SIZE(ARCLEN) < BPLP) & .OR. (SIZE(IFLAG2) < BPLP) & .OR. (SIZE(LAMBDA) < BPLP) & .OR. (SIZE(NFE) < BPLP) & .OR. (SIZE(ROOTS,DIM=2) < BPLP) ) THEN IFLAG1 = -6 RETURN END IF END IF ! Check SCALE_FACTORS array size. IF (SIZE(SCALE_FACTORS) < N) THEN IFLAG1 = -7 RETURN END IF ! End input data check. ! Initialize the POINTER aguments of POLSYS_PLP. MAXT = MAXVAL((/(NUMT(I),I=1,N)/)) IF ( .NOT. PRESENT(RECALL)) THEN CALL BEZOUT_PLP(N,MAXT,SINGTOL,BPLP) BPLP_SAVE = BPLP ! Save Bezout number for recall check. IF (ASSOCIATED(ARCLEN)) THEN IF (SIZE(ARCLEN) < BPLP) THEN DEALLOCATE(ARCLEN) ; ALLOCATE(ARCLEN(BPLP)) END IF ELSE ALLOCATE(ARCLEN(BPLP)) END IF IF (ASSOCIATED(IFLAG2)) THEN IF (SIZE(IFLAG2) < BPLP) THEN DEALLOCATE(IFLAG2) ; ALLOCATE(IFLAG2(BPLP)) END IF ELSE ALLOCATE(IFLAG2(BPLP)) END IF IFLAG2 = -2 IF (ASSOCIATED(NFE)) THEN IF (SIZE(NFE) < BPLP) THEN DEALLOCATE(NFE) ; ALLOCATE(NFE(BPLP)) END IF ELSE ALLOCATE(NFE(BPLP)) END IF IF (ASSOCIATED(LAMBDA)) THEN IF (SIZE(LAMBDA) < BPLP) THEN DEALLOCATE(LAMBDA) ; ALLOCATE(LAMBDA(BPLP)) END IF ELSE ALLOCATE(LAMBDA(BPLP)) END IF IF (ASSOCIATED(ROOTS)) THEN IF (SIZE(ROOTS,DIM=2) < BPLP .OR. SIZE(ROOTS,DIM=1) < N + 1) THEN DEALLOCATE(ROOTS) ; ALLOCATE(ROOTS(N+1,BPLP)) END IF ELSE ALLOCATE(ROOTS(N+1,BPLP)) END IF END IF ! Allocate storage for the start system. DO I=1,N DO J=1,PARTITION_SIZES(I) ALLOCATE(PARTITION(I)%SET(J)%START_COEF(NUMV(I,J))) END DO END DO ! Allocate working space for homotopy map derivative calculation. MAXPS = MAXVAL(PARTITION_SIZES) ALLOCATE(TEMP1G(N,MAXPS), TEMP2G(N,MAXPS)) ! Get real random numbers uniformly distributed in [-1,-1/2] union ! [1/2,1] for RAND_MAT, which is used in SINGSYS_PLP. CALL RANDOM_NUMBER(HARVEST=RANDNUMS) RANDNUMS = RANDNUMS - 0.5 + SIGN(0.5,RANDNUMS - 0.5) RAND_MAT = REAL(RANDNUMS,KIND=R8) ! Set default value for singularity threshold SINGTOL in SINGSYS_PLP. IF (SINGTOL <= REAL(N,KIND=R8)*EPSILON(1.0_R8)) & SINGTOL = SQRT(EPSILON(1.0_R8)) ! Scale the target polynomial system as requested. IF (PRESENT(NO_SCALING)) THEN SCALE_FACTORS = 0.0_R8 ELSE IF (.NOT. PRESENT(RECALL)) THEN CALL SCALE_PLP END IF ! Initialize the start system for the homotopy map. CALL INIT_PLP ! Set main loop initial values. FLEX_NUM(1:N-1) = 1 FLEX_NUM(N) = 0 FLEX_SAVE = 0 ROOT_COUNT = 0 IF (PRESENT(NUMRR)) THEN NUM_RERUNS = MAX(NUMRR,1) ELSE NUM_RERUNS = 1 END IF ! Main loop over all possible lexicographic vectors FLEX_NUM(1:N) ! corresponding to linear factors. MAIN_LOOP: & DO DO J=N,1,-1 IF (FLEX_NUM(J) < PARTITION_SIZES(J)) THEN K = J EXIT END IF END DO FLEX_NUM(K) = FLEX_NUM(K) + 1 IF (K + 1 <= N) FLEX_NUM(K+1:N) = 1 ! Check if the subsystem of the start system defined by the ! lexicographic vector FLEX_NUM is singular. CALL SINGSYS_PLP(N,FLEX_NUM,FLEX_SAVE,SINGTOL,RAND_MAT,MAT,NONSING) ! If the subsystem is nonsingular, track a path. NONSING_START_POINT: IF (NONSING) THEN BTEMP = PRODUCT( (/(SD(I,FLEX_NUM(I)),I=1,N)/) ) DLEX_NUM(1:N-1) = 1 DLEX_NUM(N) = 0 DLEX_SAVE = 0 ! Cycle through all lexicographic vectors DLEX_NUM(1:N) corresponding ! to roots of unity, defined by the set degrees specified in ! (/(SD(I,FLEX_NUM(I)),I=1,N)/). SD_LEX_LOOP: DO II=1,BTEMP DO JJ=N,1,-1 IF (DLEX_NUM(JJ) < SD(JJ,FLEX_NUM(JJ))) THEN KK = JJ EXIT END IF END DO DLEX_NUM(KK) = DLEX_NUM(KK) + 1 IF (KK + 1 <= N) DLEX_NUM(KK+1:N) = 1 ROOT_COUNT = ROOT_COUNT + 1 IF (IFLAG2(ROOT_COUNT) /= -2) CYCLE SD_LEX_LOOP ! Get the start point for the homotopy path defined by FLEX_NUM and ! DLEX_NUM. CALL START_POINTS_PLP NNFE = 0 IFLAG = -2 Y(1) = 0.0_R8 ; Y(2:2*N+1) = Z(1:2*N) YP(1) = 1.0_R8 ; YP(2:2*N+1) = 0.0_R8 YOLD = Y ; YPOLD = YP HOLD = 1.0_R8 ; H = 0.1_R8 S = 0.0_R8 LIMIT = 1000*NUM_RERUNS START = .TRUE. CRASH = .FALSE. ! Track the homotopy path. TRACKER: DO ITER=1,LIMIT IF (Y(1) < 0.0_R8) THEN IFLAG = 5 EXIT TRACKER END IF ! Set different error tolerance if the trajectory Y(S) has any high ! curvature components. RELERR = TRACKTOL ABSERR = TRACKTOL IF (ANY(ABS(YP - YPOLD) > 10.0_R8*HOLD)) THEN RELERR = FINALTOL ABSERR = FINALTOL END IF ! Take a step along the homotopy zero curve. CALL STEP_PLP IF (IFLAG > 0) EXIT TRACKER IF (Y(1) >= .97_R8) THEN RELERR = FINALTOL ABSERR = FINALTOL ! Enter end game. CALL ROOT_PLP EXIT TRACKER END IF ! D LAMBDA/DS >= 0 necessarily. This condition is forced here. IF (YP(1) < 0.0_R8) THEN ! Reverse the tangent direction so D LAMBDA/DS = YP(1) > 0. YP = -YP YPOLD = YP ! Force STEPNX to use the linear predictor for the next step only. START = .TRUE. END IF END DO TRACKER ! Set error flag if limit on number of steps exceeded. IF (ITER >= LIMIT) IFLAG = 3 ARCLEN(ROOT_COUNT) = S NFE(ROOT_COUNT) = NNFE IFLAG2(ROOT_COUNT) = IFLAG LAMBDA(ROOT_COUNT) = Y(1) ! Convert from real to complex arithmetic. XC(1:N) = CMPLX(Y(2:2*N:2),Y(3:2*N+1:2),KIND=R8) ! Untransform and unscale solutions. CALL OUTPUT_PLP ROOTS(1:N,ROOT_COUNT) = XC(1:N) ROOTS(N+1,ROOT_COUNT) = XC(N+1) END DO SD_LEX_LOOP END IF NONSING_START_POINT IF (ALL(FLEX_NUM == PARTITION_SIZES)) EXIT MAIN_LOOP END DO MAIN_LOOP ! Clean up working storage in STEPNX. IFLAG = -42 CALL STEPNX (2*N,NNFE,IFLAG,START,CRASH,HOLD,H,RELERR, & ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR) ! Deallocate the storage for the start system and working storage. DO I=1,N DO J=1,PARTITION_SIZES(I) DEALLOCATE(PARTITION(I)%SET(J)%START_COEF) END DO END DO DEALLOCATE(TEMP1G,TEMP2G) RETURN CONTAINS !!! SUBROUTINE SCALE_PLP ! SCALE_PLP scales the complex coefficients of a polynomial system of N ! equations in N unknowns, F(X)=0, where the Jth term of the Ith equation ! looks like ! ! C(I,J) * X(1)**D(I,J,1) ... X(N)**D(I,J,N). ! ! The Ith equation is scaled by 10**FACE(I). The Kth variable is scaled ! by 10**FACV(K). In other words, X(K)=10**FACV(K)*Y(K), where Y solves ! the scaled equation. The scaled equation has the same form as the ! original, except that CSCL(I,J) replaces POLYNOMIAL(I)%TERM(J)%COEF, ! where ! ! CSCL(I,J)=C(I,J)*10**(FACE(I)+FACV(1)*D(I,J,1)+...+FACV(N)*D(I,J,N)). ! ! The criterion for generating FACE and FACV is that of minimizing the ! sum of squares of the exponents of the scaled coefficients. It turns ! out that this criterion reduces to solving a single linear system, ! ALPHA*X=BETA, as defined in the code below. See Meintjas and Morgan, ! "A methodology for solving chemical equilibrium problems," General ! Motors Research Laboratories Technical Report GMR-4971. ! ! Calls the LAPACK routines DGEQRF, DORMQR, and the BLAS routines ! DTRSV and IDAMAX. ! ! On exit: ! ! SCALE_FACTORS(K) = FACV(K) is the scale factor for X(K), K=1,...,N. ! Precisely, the unscaled solution ! X(K) = 10**FACV(K) * (computed scaled solution). ! ! POLYNOMIAL(I)%TERM(J)%COEF = CSCL(I,J) is the scaled complex ! coefficient, for J=1,...,NUMT(I), and I=1,...,N. ! Local variables. IMPLICIT NONE INTEGER:: COUNT, I, ICMAX, IRMAX, J, K, L, LENR INTEGER, DIMENSION(N):: NNUMT INTEGER, DIMENSION(N,MAXT,N):: DDEG REAL (KIND=R8):: DUM, RTOL, TUM REAL (KIND=R8), DIMENSION(:), POINTER:: FACE, FACV REAL (KIND=R8), DIMENSION(2*N), TARGET:: BETA, RWORK, XWORK REAL (KIND=R8), DIMENSION(2*N,2*N):: ALPHA REAL (KIND=R8), DIMENSION(N,MAXT):: CMAG INTERFACE INTEGER FUNCTION IDAMAX(N,X,STRIDE) USE REAL_PRECISION INTEGER:: N,STRIDE REAL (KIND=R8), DIMENSION(N):: X END FUNCTION IDAMAX END INTERFACE LENR = N*(N+1)/2 SCALE_FACTORS(1:N) = 0.0_R8 ! This corresponds to no scaling. ! Delete exact zero coefficients, just for scaling. NNUMT = 0 DO I=1,N COUNT = 0 DO J=1,NUMT(I) IF (ABS(C(I,J)) > 0.0_R8) THEN COUNT = COUNT + 1 NNUMT(I) = NNUMT(I) + 1 CMAG(I,COUNT) = LOG10(ABS(C(I,J))) DDEG(I,COUNT,1:N) = (/(D(I,J,K),K=1,N)/) END IF END DO END DO ! Generate the matrix ALPHA. ALPHA(1:N,1:N) = 0.0_R8 DO I=1,N ALPHA(I,I) = REAL(NNUMT(I),KIND=R8) END DO DO I=1,N ALPHA(N+1:2*N,I) = REAL(SUM(DDEG(I,1:NNUMT(I),1:N),DIM=1),KIND=R8) END DO DO L=1,N DO K=1,L ICMAX = 0 DO I=1,N ICMAX = ICMAX + DOT_PRODUCT(DDEG(I,1:NNUMT(I),L),DDEG(I,1:NNUMT(I),K)) END DO ALPHA(N+L,N+K) = REAL(ICMAX,KIND=R8) ALPHA(N+K,N+L) = ALPHA(N+L,N+K) END DO END DO ALPHA(1:N,N+1:2*N) = TRANSPOSE(ALPHA(N+1:2*N,1:N)) ! Compute the QR-factorization of the matrix ALPHA. CALL DGEQRF(2*N,2*N,ALPHA,2*N,XWORK,BETA,2*N,I) ! Check for ill-conditioned scaling matrix. IRMAX = 1 ICMAX = 1 DO J=2,N I = IDAMAX(J,ALPHA(1,J),1) IF (ABS(ALPHA(I,J)) > ABS(ALPHA(IRMAX,ICMAX))) THEN IRMAX = I ICMAX = J END IF END DO RTOL = ABS(ALPHA(IRMAX,ICMAX))*EPSILON(1.0_R8)*REAL(N,KIND=R8) DO I=1,N IF (ABS(ALPHA(I,I)) < RTOL) THEN ! ALPHA is ill conditioned. RETURN ! Default to no scaling at all. END IF END DO ! Generate the column BETA. DO K=1,N BETA(K) = -SUM(CMAG(K,1:NNUMT(K))) TUM = 0.0_R8 DO I=1,N TUM = TUM + SUM(CMAG(I,1:NNUMT(I)) * REAL(DDEG(I,1:NNUMT(I),K),KIND=R8)) END DO BETA(N+K) = -TUM END DO ! Solve the linear system ALPHA*X=BETA. CALL DORMQR('L','T',2*N,1,2*N-1,ALPHA,2*N,XWORK,BETA,2*N,RWORK,2*N,I) CALL DTRSV('U','N','N',2*N,ALPHA,2*N,BETA,1) ! Generate FACE, FACV, and the scaled coefficients CSCL(I,J). FACE => BETA(1:N) FACV => BETA(N+1:2*N) DO I=1,N DO J=1,NUMT(I) DUM = ABS(C(I,J)) IF (DUM /= 0.0) THEN TUM = FACE(I) + LOG10(DUM) + DOT_PRODUCT(FACV(1:N), & POLYNOMIAL(I)%TERM(J)%DEG(1:N)) POLYNOMIAL(I)%TERM(J)%COEF = (10.0_R8**TUM) * (C(I,J)/DUM) ENDIF END DO END DO SCALE_FACTORS(1:N) = FACV(1:N) RETURN END SUBROUTINE SCALE_PLP !!! SUBROUTINE INIT_PLP ! INIT_PLP homogenizes the homotopy map, and harvests random complex ! numbers which define the start system and the projective transformation. ! ! On exit: ! ! POLYNOMIAL(I)%TERM(J)%DEG(N+1) is the degree of the homogeneous variable ! in the Jth term of the Ith component of the target system. ! ! PARTITION(I)%SET(J)%START_COEF(K) is the coefficient of X(PAR(I,J,K)) in ! the linear factor L(I,J). (L(I,J) is defined in GLOBAL_PLP.) ! ! PROJ_COEF(I) is the coefficient of X(I) in the projective transformation, ! when I=1,...,N, and the constant term in the projective transformation, ! when I=N+1. ! Local variables. IMPLICIT NONE INTEGER:: COUNT, I, J, K, SEED_SIZE INTEGER, DIMENSION(:), ALLOCATABLE:: SEED REAL, DIMENSION(N*N+N+1,2):: RANDS REAL (KIND=R8), DIMENSION(N*N+N+1,2):: RANDSR8 ! Construct the homogenization of the homotopy map. Note: ! Homogenization of the start system is implicit. DO I=1,N DO J=1,NUMT(I) POLYNOMIAL(I)%TERM(J)%DEG(N+1) = SUM((/(SD(I,K),K=1, & PARTITION_SIZES(I))/)) - SUM(POLYNOMIAL(I)%TERM(J)%DEG(1:N)) END DO END DO ! Get the random coefficients START_COEF which define the start system ! and the random coefficients PROJ_COEF which define the projective ! transformation. CALL RANDOM_SEED(SIZE=SEED_SIZE) ALLOCATE(SEED(SEED_SIZE)) SEED(1:SEED_SIZE) = 32749 CALL RANDOM_SEED(PUT=SEED(1:SEED_SIZE)) CALL RANDOM_NUMBER(HARVEST=RANDS) RANDS = 2.0 * RANDS - 1.0 RANDSR8 = REAL(RANDS,KIND=R8) COUNT = 1 DO I=1,N DO J=1,PARTITION_SIZES(I) DO K=1,NUMV(I,J) PARTITION(I)%SET(J)%START_COEF(K) = CMPLX(RANDSR8(COUNT,1), & RANDSR8(COUNT,2),KIND=R8) COUNT = COUNT + 1 END DO END DO END DO PROJ_COEF(1:N+1) = CMPLX(RANDSR8(COUNT:COUNT+N,1), & RANDSR8(COUNT:COUNT+N,2),KIND=R8) DEALLOCATE(SEED) RETURN END SUBROUTINE INIT_PLP !!! SUBROUTINE START_POINTS_PLP ! START_POINTS_PLP finds a starting point for the homotopy map ! corresponding to the lexicographic vector FLEX_NUM (defining the ! variable sets) and the lexicographic vector DLEX_NUM (defining the ! particular start point among all those defined by FLEX_NUM). The ! (complex) start point z is the solution to a nonsingular linear system ! AA z = B, defined by (cf. the notation in the module GLOBAL_PLP) ! ! L(1,FLEX_NUM(1)) - R(DLEX_NUM(1)-1,SD(1,FLEX_NUM(1))) * X(N+1) = 0, ! . ! . ! . ! L(N,FLEX_NUM(N)) - R(DLEX_NUM(N)-1,SD(N,FLEX_NUM(N))) * X(N+1) = 0, ! X(N+1) = SUM_{J=1}^N PROJ_COEF(J)*X(J) + PROJ_COEF(N+1), ! ! where the last equation is the projective transformation, X(N+1) is ! the homogeneous coordinate, and R(K,M)=e**(i*2*PI*K/M) is an Mth root ! of unity. The homogeneous variable X(N+1) is explicitly eliminated, ! resulting in an N x N complex linear system for z=(X(1),...,X(N)). ! ! START_POINTS_PLP calculates a start point in an efficient way: For each ! fixed lexicographic number LEX_NUM, the routine reuses, if possible, ! previous Householder reflections in the LQ decomposition of AA. ! ! Calls the LAPACK routines ZLARFG, ZLARFX, the BLAS routine ZTRSV, and the ! internal function ROOT_OF_UNITY. ! ! On exit: ! ! Z(1:2N) is a real vector representing the (complex) start point z. ! Local variables. IMPLICIT NONE INTEGER:: I, J, K COMPLEX (KIND=R8):: ROOT, WORK(1) ! (Re)set the coefficient matrix AA, and set B. DO I=1,N IF (DLEX_SAVE(I) /= DLEX_NUM(I)) THEN DLEX_SAVE(I+1:N) = 0 DO J=1,N ROOT = ROOT_OF_UNITY(DLEX_NUM(J)-1,SD(J,FLEX_NUM(J))) B(J) = ROOT * PROJ_COEF(N+1) IF (J >= I) THEN AA(J,1:N) = (0.0_R8,0.0_R8) K = NUMV(J,FLEX_NUM(J)) AA(J,PARTITION(J)%SET(FLEX_NUM(J))%INDEX(1:K)) = & PARTITION(J)%SET(FLEX_NUM(J))%START_COEF(1:K) AA(J,1:N) = AA(J,1:N) - PROJ_COEF(1:N) * ROOT END IF END DO EXIT END IF END DO ! Special code for the case N=1. IF (N == 1) THEN WORK(1) = B(1)/AA(1,1) Z(1) = REAL(WORK(1)) Z(2) = AIMAG(WORK(1)) DLEX_SAVE = DLEX_NUM RETURN END IF ! Update the LQ factorization of AA. IF (DLEX_SAVE(1) /= DLEX_NUM(1)) THEN AA(1,1:N) = CONJG(AA(1,1:N)) CALL ZLARFG(N,AA(1,1),AA(1,2:N),1,TAU(1)) END IF DO I=2,N IF (DLEX_SAVE(I) /= DLEX_NUM(I)) THEN DO J=1,I-1 V(J) = (1.0_R8,0.0_R8) V(J+1:N) = AA(J,J+1:N) CALL ZLARFX('R',1,N-J+1,V(J:N),TAU(J),AA(I,J:N),1,WORK) END DO IF (I < N) THEN AA(I,I:N) = CONJG(AA(I,I:N)) CALL ZLARFG(N-I+1,AA(I,I),AA(I,I+1:N),1,TAU(I)) END IF END IF END DO DLEX_SAVE = DLEX_NUM ! Solve the linear system AA Z = B, by solving L Q Z = B. ! L W = B. CALL ZTRSV('L','N','N',N,AA(1:N,1:N),N,B(1:N),1) ! Z = CONJG(Q') W. DO I=N-1,1,-1 V(I) = (1.0_R8,0.0_R8) V(I+1:N) = AA(I,I+1:N) CALL ZLARFX('L',N-I+1,1,V(I:N),TAU(I),B(I:N),N,WORK) END DO ! Convert the complex start point to a real vector. Z(1:2*N:2) = REAL(B) Z(2:2*N:2) = AIMAG(B) RETURN END SUBROUTINE START_POINTS_PLP !!! COMPLEX (KIND=R8) FUNCTION ROOT_OF_UNITY(K,N) RESULT(RU) ! RU = e**(i*2*PI*K/N). IMPLICIT NONE INTEGER:: K, N REAL (KIND=R8):: ANGLE ANGLE = 2.0_R8*PI*(REAL(K,KIND=R8)/REAL(N,KIND=R8)) RU = CMPLX(COS(ANGLE),SIN(ANGLE),KIND=R8) RETURN END FUNCTION ROOT_OF_UNITY !!! SUBROUTINE STEP_PLP ! Driver for reverse call external subroutine STEPNX from HOMPACK90. IMPLICIT NONE INTEGER:: FAIL=0,IFLAGS STEP: DO CALL STEPNX(2*N,NNFE,IFLAG,START,CRASH,HOLD,H,RELERR, & ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR) IF (CRASH) THEN IFLAG = 2 EXIT END IF IFLAGS = IFLAG SELECT CASE (IFLAGS) CASE (-2) ! Successful step. EXIT CASE (-12) ! Compute tangent vector. RHOLEN = 0.0_R8 CALL TANGENT_PLP IF (IFLAG == 4) THEN IFLAG = IFLAGS - 100 FAIL = FAIL + 1 ENDIF CASE (-32,-22) ! Compute tangent vector and Newton step. RHOLEN = -1.0_R8 CALL TANGENT_PLP(NEWTON_STEP=.TRUE.) IF (IFLAG == 4) THEN IFLAG = IFLAGS - 100 FAIL = FAIL + 1 ENDIF CASE (4,6) ! STEPNX failed. EXIT END SELECT IF (FAIL == 2) THEN IFLAG = 4 ; RETURN ENDIF END DO STEP RETURN END SUBROUTINE STEP_PLP !!! SUBROUTINE TANGENT_PLP(NEWTON_STEP) ! This subroutine builds the Jacobian matrix of the homotopy map, ! computes a QR decomposition of that matrix, and then calculates the ! (unit) tangent vector and (if NEWTON_STEP is present) the Newton ! step. ! ! On input: ! ! NEWTON_STEP is a logical optional argument which, if present, ! indicates that the Newton step is also to be calculated. ! ! RHOLEN < 0 if the norm of the homotopy map evaluated at ! (LAMBDA, X) is to be computed. If RHOLEN >= 0 the norm is not ! computed and RHOLEN is not changed. ! ! W(1:2*N+1) = current point (LAMBDA(S), X(S)). ! ! YPOLD(1:2*N+1) = unit tangent vector at previous point on the zero ! curve of the homotopy map. ! ! On output: ! ! RHOLEN = ||RHO(LAMBDA(S), X(S))|| if RHOLEN < 0 on input. ! Otherwise RHOLEN is unchanged. ! ! WP(1:2*N+1) = dW/dS = unit tangent vector to integral curve of ! d(homotopy map)/dS = 0 at W(S) = (LAMBDA(S), X(S)) . ! ! TZ = the Newton step = -(pseudo inverse of (d RHO(W(S))/d LAMBDA , ! d RHO(W(S))/dX)) * RHO(W(S)) . ! ! IFLAG is unchanged, unless the QR factorization detects a rank < N, ! in which case the tangent and Newton step vectors are not computed ! and TANGENT_PLP returns with IFLAG = 4 . ! ! ! Calls DGEQPF, DNRM2, DORMQR, RHO. IMPLICIT NONE LOGICAL, INTENT(IN), OPTIONAL:: NEWTON_STEP REAL (KIND=R8):: LAMBDA, SIGMA, WPNORM INTEGER:: I, J, K INTERFACE FUNCTION DNRM2(N,X,STRIDE) USE REAL_PRECISION INTEGER:: N,STRIDE REAL (KIND=R8):: DNRM2,X(N) END FUNCTION DNRM2 END INTERFACE ! Compute the Jacobian matrix, store it and homotopy map in QR. ! ! QR = ( D RHO(LAMBDA,X)/D LAMBDA , D RHO(LAMBDA,X)/DX , ! RHO(LAMBDA,X) ) . ! ! Force LAMBDA >= 0 for tangent calculation. IF (W(1) < 0.0_R8) THEN LAMBDA = 0.0_R8 ELSE LAMBDA = W(1) END IF ! RHO(W) evaluates the homotopy map and its Jacobian matrix at W, ! leaving the results in the arrays RHOV, DRHOL, and DRHOX. CALL RHO(LAMBDA,W(2:2*N+1)) QR(1:2*N,1) = DRHOL(1:2*N) QR(1:2*N,2:2*N+1) = DRHOX(1:2*N,1:2*N) QR(1:2*N,2*N+2) = RHOV(1:2*N) ! Compute the norm of the homotopy map if it was requested. IF (RHOLEN < 0.0_R8) RHOLEN = DNRM2(2*N,QR(:,2*N+2),1) ! Reduce the Jacobian matrix to upper triangular form. PIVOT = 0 CALL DGEQPF(2*N,2*N+1,QR,2*N,PIVOT,WP,ALPHA,K) IF (ABS(QR(2*N,2*N)) <= ABS(QR(1,1))*EPSILON(1.0_R8)) THEN IFLAG = 4 RETURN ENDIF ! Apply Householder reflections to last column of QR (which contains ! RHO(A,W)). CALL DORMQR('L','T',2*N,1,2*N-1,QR,2*N,WP,QR(:,2*N+2),2*N, & ALPHA, 3*(2*N+1),K) ! Compute kernel of Jacobian matrix, yielding WP=dW/dS. TZ(2*N+1) = 1.0_R8 DO I=2*N,1,-1 J = I + 1 TZ(I) = -DOT_PRODUCT(QR(I,J:2*N+1),TZ(J:2*N+1))/QR(I,I) END DO WPNORM = DNRM2(2*N+1,TZ,1) WP(PIVOT) = TZ/WPNORM IF (DOT_PRODUCT(WP,YPOLD) < 0.0_R8) WP = -WP ! WP is the unit tangent vector in the correct direction. IF (.NOT. PRESENT(NEWTON_STEP)) RETURN ! Compute the minimum norm solution of [d RHO(W(S))] V = -RHO(W(S)). ! V is given by P - (P,Q)Q , where P is any solution of ! [d RHO] V = -RHO and Q is a unit vector in the kernel of [d RHO]. ALPHA(2*N+1) = 1.0_R8 DO I=2*N,1,-1 J = I + 1 ALPHA(I) = -(DOT_PRODUCT(QR(I,J:2*N+1),ALPHA(J:2*N+1)) + QR(I,2*N+2)) & /QR(I,I) END DO TZ(PIVOT) = ALPHA(1:2*N+1) ! TZ now contains a particular solution P, and WP contains a vector Q ! in the kernel (the unit tangent). SIGMA = DOT_PRODUCT(TZ,WP) TZ = TZ - SIGMA*WP ! TZ is the Newton step from the current point W(S) = (LAMBDA(S), X(S)). RETURN END SUBROUTINE TANGENT_PLP !!! SUBROUTINE ROOT_PLP ! In a deleted neighborhood of a solution (1,X(SBAR)), the homotopy zero ! curve (LAMBDA(S),X(S)) is assumed to safisfy X = X(LAMBDA), a consequence ! of the Implicit Function Theorem and the fact that the Jacobian matrix ! D RHO(A,LAMBDA(S),X(S))/DX is nonsingular in a sufficiently small ! deleted neighborhood of an isolated solution. Let ! TAU = 1 - LAMBDA = SIGMA**C, ! where the positive integer C is the cycle number of the root. Then ! X(LAMBDA) = X(1 - TAU) = X(1 - SIGMA**C) = Z(SIGMA) ! is an analytic function of SIGMA in a neighborhood of SIGMA=0. This fact ! is exploited by guessing C and interpolating Z(SIGMA) within its ! Maclaurin series' radius of convergence, but far enough away from 0 to ! avoid numerical instability. This annulus is called the "operating ! range" of the algorithm. The interpolant to analytic Z(SIGMA) is then ! evaluated at SIGMA=0 to estimate the root X(1)=Z(0). ! Local variables. IMPLICIT NONE INTEGER, PARAMETER:: CHAT_MAX=8, LITFH = 7 INTEGER:: C, CHAT(1), CHAT_BEST, CHAT_OLD, GOING_BAD, I, & J, ML_ITER, N2P1, RETRY REAL (KIND=R8):: ACCURACY, FV(12), GM, H_SAVE, HC, HQ, HQ_BEST, & HQMHC(CHAT_MAX), L(-3:2), S_SAVE, SIGMA(-3:2), SHRINK, T, TOL_1, & TOL_2, V(12) LOGICAL:: EVEN, FIRST_JUMP, REUSE INTERFACE FUNCTION DNRM2(N,X,STRIDE) USE REAL_PRECISION INTEGER:: N, STRIDE REAL (KIND=R8):: DNRM2, X(N) END FUNCTION DNRM2 END INTERFACE N2P1 = 2*N + 1 ACCURACY = MAX(FINALTOL,SQRT(EPSILON(1.0_R8))*10.0_R8**2) HQ_BEST = 10.0_R8*ACCURACY CHAT_BEST = 0 ; CHAT_OLD = 0 ; GOING_BAD = 0 FIRST_JUMP = .TRUE. ; REUSE = .FALSE. YOLDS = 0.0_R8 ! Save the first point. H_SAVE = HOLD S_SAVE = S - HOLD YS(:,1) = YOLD ; YS(:,2) = YPOLD ! If Y(1) >= 1 or if YP(1) <= 0 back up to YOLD and generate another point. REFINE_Y: DO IF ((Y(1) >= 1.0_R8) .OR. (YP(1) <= 0.0_R8)) THEN SHRINK = 1.0_R8 ! Try 3 times to get a point. DO I=1,3 SHRINK = SHRINK * .75_R8 S = S_SAVE H = MIN(H_SAVE, SHRINK*(1.0_R8 - YS(1,1))/YS(1,2)) ! If Y(1)>=1 increase RELERR and ABSERR to prevent STEPNX from making ! the stepsize too small. IF (Y(1) >= 1.0_R8) THEN RELERR = TRACKTOL ; ABSERR = TRACKTOL END IF Y = YS(:,1) ; YP = YS(:,2) START = .TRUE. CALL STEP_PLP RELERR = FINALTOL ; ABSERR = FINALTOL IF (IFLAG > 0) THEN IFLAG = 4 ; RETURN ELSE IF ((Y(1) < 1.0_R8) .AND. (YP(1) > 0.0_R8) .AND. & (Y(1) > YS(1,1))) THEN ITER = ITER + 1 EXIT REFINE_Y ELSE IF (I == 3) THEN IFLAG = 7 ; RETURN END IF END DO ELSE ! Refine the second point Y to FINALTOL accuracy. If the refinement ! fails, back up and get another point. W = Y RHOLEN = 0.0_R8 DO J=1,LITFH CALL TANGENT_PLP(NEWTON_STEP=.TRUE.) NNFE = NNFE + 1 IF (IFLAG > 0) THEN IFLAG = -2 YP(1) = -1.0_R8 ; CYCLE REFINE_Y END IF W = W + TZ ! Test for erratic LAMBDA. IF (W(1) >= 1.0_R8 .OR. WP(1) <= 0.0_R8 .OR. W(1) <= YS(1,1)) THEN YP(1) = -1.0_R8 ; CYCLE REFINE_Y END IF IF (DNRM2(N2P1,TZ,1) <= FINALTOL * (DNRM2(N2P1,W,1) + 1.0_R8)) EXIT ! Test for lack of convergence. IF (J == LITFH) THEN YP(1) = -1.0_R8 ; CYCLE REFINE_Y END IF END DO Y = W ; YP = WP S = S - HOLD W = Y - YOLD HOLD = DNRM2(N2P1,W,1) S = S + HOLD EXIT REFINE_Y END IF END DO REFINE_Y ! Save the second point. YS(:,3) = Y ; YS(:,4) = YP H_SAVE = H ; S_SAVE = S ! Try entire end game interpolation process RETRY=10*NUMRR times. RETRY = 10*NUM_RERUNS MAIN_LOOP: & DO ML_ITER=1,RETRY ! Get close enough to SIGMA=0 (LAMBDA=1) so that a Hermite cubic ! interpolant is accurate to within TOL_1 (defined by CHAT). OPERATING_RANGE: DO ! Enforce LIMIT on the number of steps. IF (ITER >= LIMIT) THEN IFLAG = 3 ; EXIT MAIN_LOOP END IF SHRINK = 1.0_R8 DO J=1,3 SHRINK = .75_R8*SHRINK ! Get a third point Y with Y(1) < 1. H = MIN(H_SAVE, SHRINK*(1.0_R8 - Y(1))/YP(1)) CALL STEP_PLP IF (IFLAG > 0) THEN IFLAG = 4 ; EXIT MAIN_LOOP ELSE IF ((Y(1) >= 1.0_R8) .OR. (YP(1) <= 0.0_R8) .OR. & (Y(1) <= YS(1,3))) THEN ! Back up and try again with a smaller step. Y = YS(:,3) ; YP = YS(:,4) ; YOLD = YS(:,1) ; YPOLD = YS(:,2) S = S_SAVE ELSE ITER = ITER + 1 EXIT END IF IF (J == 3) THEN IFLAG = 7 ; EXIT MAIN_LOOP END IF END DO ! Save the third point. YS(:,5) = Y ; YS(:,6) = YP H_SAVE = H ; S_SAVE = S ! L(2) < L(1) < L(0) < 1. L(2) = YS(1,1) ; L(1) = YS(1,3) ; L(0) = YS(1,5) ! Test approximation quality for each cycle number C = 1,...,CHAT_MAX. SHRINK = 1.0_R8/(1.0_R8 + MAXVAL(ABS(YS(2:N2P1,5)))) DO C=1,CHAT_MAX SIGMA(0:2) = (1.0_R8 - L(0:2))**(1.0_R8/REAL(C,KIND=R8)) ! 0 < SIGMA(0) < SIGMA(1) < SIGMA(2). ! Compute difference between Hermite quintic HQ(SIGMA) interpolating at ! SIGMA(0:2) and Hermite cubic HC(SIGMA) interpolating at SIGMA(0:1). ! The interpolation points for the Newton form are (SIGMA(0), SIGMA(0), ! SIGMA(1), SIGMA(1), SIGMA(2), SIGMA(2)). The function values are in ! YS(:,5:1:-2) and the derivatives YS(:,6:2:-2) = dX/dS have to be ! converted to dX/dSIGMA. T = 0.0_R8 V(1:6) = (/ (SIGMA(J),SIGMA(J),J=0,2) /) DO J=2,N2P1 FV(1:5:2) = YS(J,5:1:-2) FV(2:6:2) = (YS(J,6:2:-2)/YS(1,6:2:-2)) * (-REAL(C,KIND=R8)) * & SIGMA(0:2)**(C-1) CALL INTERP(V(1:6),FV(1:6)) T = MAX(T,ABS(FV(5) - SIGMA(2)*FV(6))) END DO ! T*(SIGMA(1)*SIGMA(0))**2 = ||HQ(0) - HC(0)||_infty. HQMHC(C) = T*((SIGMA(1)*SIGMA(0))**2)*SHRINK END DO ! Find best estimate CHAT of cycle number. CHAT = MINLOC(HQMHC) ! If there has been one successful jump across the origin (with ! CHAT_BEST) and the cycle number prediction changes, then the process ! may be leaving the operating range. IF (( .NOT. FIRST_JUMP) .AND. (CHAT(1) /= CHAT_BEST)) THEN GOING_BAD = GOING_BAD + 1 IF (GOING_BAD == 2) EXIT MAIN_LOOP END IF TOL_1 = ACCURACY*10.0_R8**(REAL(CHAT(1),KIND=R8)/2.0_R8) IF (HQMHC(CHAT(1)) <= TOL_1) THEN EXIT OPERATING_RANGE ELSE IF ( .NOT. FIRST_JUMP) THEN GOING_BAD = GOING_BAD + 1 IF (GOING_BAD == 2) EXIT MAIN_LOOP END IF ! Shift point history, and try to get closer to SIGMA=0. YS(:,1:2) = YS(:,3:4) ; YS(:,3:4) = YS(:,5:6) ; REUSE = .FALSE. END DO OPERATING_RANGE ! Add 3 new points past SIGMA=0 such that ! SIGMA(2) > SIGMA(1) > SIGMA(0) > 0 > SIGMA(-1) > SIGMA(-2) > SIGMA(-3). ! If CHAT is odd then the corresponding LAMBDA are such that ! L(2) < L(1) < L(0) < 1 < L(-1) < L(-2) < L(-3), ! and if CHAT is even then ! L(2) < L(1) < L(0) < 1 ! 1 > L(-1) > L(-2) > L(-3). SIGMA(0:2) = (1.0_R8 - L(0:2))**(1.0_R8/REAL(CHAT(1),KIND=R8)) DO I=1,3 V(1:4+2*I) = (/ (SIGMA(J),SIGMA(J),J=2,1-I,-1) /) DO J=2,N2P1 FV(1:3+2*I:2) = YS(J,1:3+2*I:2) FV(2:4+2*I:2) = (YS(J,2:4+2*I:2)/YS(1,2:4+2*I:2)) * & (-REAL(CHAT(1),KIND=R8)) * SIGMA(2:1-I:-1)**(CHAT(1)-1) CALL INTERP(V(1:4+2*I),FV(1:4+2*I)) CALL INTERP(V(1:4+2*I),FV(1:4+2*I),-SIGMA(I-1),W(J)) END DO IF (MOD(CHAT(1),2) == 0) THEN EVEN = .TRUE. W(1) = L(I-1) ELSE EVEN = .FALSE. W(1) = 2.0_R8 - L(I-1) END IF ! W now contains the (predicted) point symmetric to SIGMA(I-1) with ! respect to SIGMA=0. RHOLEN = 0.0_R8 ! Correct the prediction. If there has been one successful jump across ! the origin, correction failures may indicate that the process is ! leaving the operating range. DO J=1,LITFH CALL TANGENT_PLP(NEWTON_STEP=.TRUE.) NNFE = NNFE + 1 ! Test for singular Jacobian matrix. IF (IFLAG > 0) EXIT MAIN_LOOP W = W + TZ ! Test for erratic LAMBDA. IF ((( .NOT. EVEN) .AND. (W(1) <= 1.0_R8)) .OR. & (EVEN .AND. (W(1) >= 1.0_R8))) THEN IF ( .NOT. FIRST_JUMP) THEN GOING_BAD = GOING_BAD + 1 IF (GOING_BAD == 2) EXIT MAIN_LOOP END IF YS(:,1:2) = YS (:,3:4) ; YS(:,3:4) = YS(:,5:6) REUSE = .FALSE. ; CYCLE MAIN_LOOP END IF IF (DNRM2(N2P1,TZ,1) <= FINALTOL * (DNRM2(N2P1,W,1) + 1.0_R8)) EXIT ! Test for lack of convergence. IF (J == LITFH) THEN IF ( .NOT. FIRST_JUMP) THEN GOING_BAD = GOING_BAD + 1 IF (GOING_BAD == 2) EXIT MAIN_LOOP END IF YS(:,1:2) = YS (:,3:4) ; YS(:,3:4) = YS(:,5:6) REUSE = .FALSE. ; CYCLE MAIN_LOOP END IF END DO ! Ensure that the tangent vector has the correct direction. IF (EVEN) THEN IF (WP(1) > 0.0_R8) WP = -WP ELSE IF (WP(1) < 0.0_R8) WP = -WP END IF ! Update the lambda (L), sigma (SIGMA), and history (YS) arrays. L(-I) = W(1) SIGMA(-I) = -(ABS(L(-I) - 1.0_R8))**(1.0_R8/REAL(CHAT(1),KIND=R8)) YS(:,5+2*I) = W ; YS(:,6+2*I) = WP ! Reuse old points if the cycle number estimation has not changed ! from the last iteration, and the origin was successfully jumped in ! the last iteration. IF (REUSE .AND. (CHAT(1) == CHAT_OLD)) EXIT END DO ! Construct 12th order interpolant and estimate the root at SIGMA=0. HC = 0.0_R8 ; HQ = 0.0_R8 ; T = 0.0_R8 V(1:12) = (/ (SIGMA(J),SIGMA(J),J=-3,2) /) DO J=2,N2P1 FV(1:11:2) = YS(J,11:1:-2) FV(2:12:2) = (YS(J,12:2:-2)/YS(1,12:2:-2)) * & (-REAL(CHAT(1),KIND=R8)) * SIGMA(-3:2)**(CHAT(1)-1) CALL INTERP(V(1:12),FV(1:12)) CALL INTERP(V(1:12),FV(1:12),0.0_R8,W(J)) ! Difference between 8th and 6th order Hermite interpolants. T = MAX(T ,ABS(FV( 7) - SIGMA(0)*FV( 8))) ! Difference between 10th and 8th order Hermite interpolants. HC = MAX(HC,ABS(FV( 9) - SIGMA(1)*FV(10))) ! Difference between 12th and 10th order Hermite interpolants. HQ = MAX(HQ,ABS(FV(11) - SIGMA(2)*FV(12))) END DO SHRINK = 1.0_R8/(1.0_R8 + MAXVAL(ABS(W(2:N2P1)))) T = T*((PRODUCT(SIGMA(-3:-1)))**2)*SHRINK ! ||H_7 - H_5||/(1+||W||) HC = HC*((PRODUCT(SIGMA(-3: 0)))**2)*SHRINK ! ||H_9 - H_7||/(1+||W||) HQ = HQ*((PRODUCT(SIGMA(-3: 1)))**2)*SHRINK ! ||H_11 - H_9||/(1+||W||) ! Check both accuracy and consistency of Hermite interpolants. TOL_2 = FINALTOL * (10**(CHAT(1) - 1)) GM = SQRT(TOL_1 * TOL_2) IF ((T <= TOL_1) .AND. (HC <= GM) .AND. (HQ <= TOL_2)) THEN ! Full convergence. IF (FIRST_JUMP) FIRST_JUMP = .FALSE. YOLDS(2:N2P1) = W(2:N2P1) ; HQ_BEST = HQ CHAT_BEST = CHAT(1) EXIT MAIN_LOOP ELSE IF (HQ > 1.01_R8*HQ_BEST) THEN IF ( .NOT. FIRST_JUMP) THEN GOING_BAD = GOING_BAD + 1 IF (GOING_BAD == 2) EXIT MAIN_LOOP END IF ELSE ! Progress has been made. IF (FIRST_JUMP) FIRST_JUMP = .FALSE. GOING_BAD = 0 YOLDS(2:N2P1) = W(2:N2P1) ; HQ_BEST = HQ CHAT_BEST = CHAT(1) END IF ! Shift point history. YS(:,1:2) = YS(:,3:4) ; YS(:,3:4) = YS(:,5:6) ! If the cycle number estimate does not change in the next iteration, the ! points found across the origin can be reused. REUSE = .TRUE. ; CHAT_OLD = CHAT(1) SIGMA(-3) = SIGMA(-2) ; SIGMA(-2) = SIGMA(-1) YS(:,11:12) = YS(:,9:10) ; YS(:,9:10) = YS(:,7:8) END DO MAIN_LOOP IF (ML_ITER >= RETRY) IFLAG = 7 ! Return final solution in Y. IF ( .NOT. FIRST_JUMP) THEN Y(1) = HQ_BEST ; Y(2:N2P1) = YOLDS(2:N2P1) IFLAG = 1 + 10*CHAT_BEST END IF RETURN END SUBROUTINE ROOT_PLP !!! SUBROUTINE INTERP(T,FT,X,FX) ! Given data points T(:) and function values FT(:)=f(T(:)), INTERP ! computes the Newton form of the interpolating polynomial to f at T(:). ! T is assumed to be sorted, and if ! T(I-1) < T(I) = T(I+1) = ... = T(I+K) < T(I+K+1) then ! FT(I)=f(T(I)), FT(I+1)=f'(T(I)), ..., FT(I+K)=f^{(K)}(T(I)). ! On return FT(K) contains the divided difference f[T(1),...,T(K)], and ! FX contains the interpolating polynomial evaluated at X. If X and FX ! are present, the divided differences are not calculated. IMPLICIT NONE REAL (KIND=R8), DIMENSION(:):: T, FT REAL (KIND=R8), OPTIONAL:: X, FX ! Local variables. REAL (KIND=R8):: FOLD,SAVE INTEGER:: I,K,N N = SIZE(T) IF (.NOT. PRESENT(X)) THEN ! Calculate divided differences. DO K=1,N-1 FOLD = FT(K) DO I=K+1,N IF (T(I) == T(I-K)) THEN FT(I) = FT(I)/REAL(K,KIND=R8) ELSE SAVE = FT(I) FT(I) = (FT(I) - FOLD)/(T(I) - T(I-K)) FOLD = SAVE END IF END DO END DO RETURN END IF FX = FT(N) ! Evaluate Newton polynomial. DO K=N-1,1,-1 FX = FX*(X - T(K)) + FT(K) END DO RETURN END SUBROUTINE INTERP !!! SUBROUTINE RHO(LAMBDA,X) ! RHO evaluates the (complex) homotopy map ! ! RHO(A,LAMBDA,X) = LAMBDA*F(X) + (1 - LAMBDA)*GAMMA*G(X), ! ! where GAMMA is a random complex constant, and the Jacobian ! matrix [ D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX ] at ! (A,LAMBDA,X), and updates the global arrays RHOV (the homotopy map), ! DRHOX (the derivative of the homotopy with repect to X) , and DRHOL ! (the derivative with respect to LAMBDA). The vector A corresponds ! mathematically to all the random coefficients in the start system, and ! is not explicitly referenced by RHO. X, on entry, is real, but since ! arithmetic in RHO is complex, X is converted to complex form. Before ! return RHO converts the homotopy map and the two derivatives back to ! real. Precisely, suppose XC is the complexification of X, i.e., ! ! XC(1:N)=CMPLX(X(1:2*N-1:2),X(2:2*N:2)). ! ! Let CRHOV(A,LAMBDA,XC) be the (complex) homotopy map. Then RHOV ! is just ! ! RHOV(1:2*N-1:2) = REAL( CRHOV(1:N)), ! RHOV(2:2*N :2) = AIMAG(CRHOV(1:N)). ! ! Let CDRHOXC = D CRHOV(A,LAMBDA,XC)/D XC denote the (complex) derivative ! of the homotopy map with respect to XC, evaluated at (A,LAMBDA,XC). ! DRHOX is obtained by ! ! DRHOX(2*I-1,2*J-1) = REAL(CDRHOXC(I,J)), ! DRHOX(2*I ,2*J ) = DRHOX(2*I-1,2*J-1), ! DRHOX(2*I ,2*J-1) = AIMAG(CDRHOXC(I,J)), ! DRHOX(2*I-1,2*J ) = -DRHOX(2*I ,2*J-1), ! ! for I, J = 1,...,N. Let CDRHOL = D CRHOV(A,LAMBDA,XC)/D LAMBDA denote ! the (complex) derivative of the homotopy map with respect to LAMBDA, ! evaluated at (A,LAMBDA,XC). Then DRHOL is obtained by ! ! DRHOL(1:2*N-1:2) = REAL( CDRHOL(1:N)), ! DRHOL(2:2*N :2) = AIMAG(CDRHOL(1:N)). ! ! (None of CRHOV, CDRHOXC, or CDRHOL are in the code.) ! ! Internal subroutines: START_SYSTEM, TARGET_SYSTEM. ! External (optional, user written) subroutine: TARGET_SYSTEM_USER. ! ! On input: ! ! LAMBDA is the continuation parameter. ! ! X(1:2*N) is the real 2*N-dimensional evaluation point. ! ! On exit: ! ! LAMBDA and X are unchanged. ! ! RHOV(1:2*N) is the real (2*N)-dimensional representation of the ! homotopy map RHO(A,LAMBDA,X). ! ! DRHOX(1:2*N,1:2*N) is the real (2*N)-by-(2*N)-dimensional ! representation of D RHO(A,LAMBDA,X)/DX evaluated at (A,LAMBDA,X). ! ! DRHOL(1:2*N) is the real (2*N)-dimensional representation of ! D RHO(A,LAMBDA,X)/D LAMBDA evaluated at (A,LAMBDA,X). IMPLICIT NONE REAL (KIND=R8), INTENT(IN):: LAMBDA REAL (KIND=R8), DIMENSION(2*N), INTENT(IN):: X INTERFACE SUBROUTINE TARGET_SYSTEM_USER(N,PROJ_COEF,XC,F,DF) USE REAL_PRECISION INTEGER, INTENT(IN):: N COMPLEX (KIND=R8), INTENT(IN), DIMENSION(N+1):: PROJ_COEF,XC COMPLEX (KIND=R8), INTENT(OUT):: F(N), DF(N,N+1) END SUBROUTINE TARGET_SYSTEM_USER END INTERFACE ! Local variables. INTEGER:: I, J REAL (KIND=R8):: ONEML COMPLEX (KIND=R8):: GAMMA ONEML = 1.0_R8 - LAMBDA GAMMA = (.0053292102547824_R8,.9793238462643383_R8) ! Convert the real-valued evaluation point X to a complex vector. XC(1:N) = CMPLX(X(1:2*N-1:2),X(2:2*N:2),KIND=R8) ! Calculate the homogeneous variable. XC(N+1) = SUM(PROJ_COEF(1:N)*XC(1:N)) + PROJ_COEF(N+1) CALL START_SYSTEM ! Returns G and DG. IF (PRESENT(USER_F_DF)) THEN ! Returns F and DF. CALL TARGET_SYSTEM_USER(N,PROJ_COEF,XC,F,DF) ! User written subroutine. ELSE CALL TARGET_SYSTEM ! Internal subroutine. END IF ! Convert complex derivatives to real derivatives via the Cauchy-Riemann ! equations. DO I=1,N DO J=1,N DRHOX(2*I-1,2*J-1) = LAMBDA*REAL(DF(I,J)) + ONEML*REAL(DG(I,J)*GAMMA) DRHOX(2*I ,2*J ) = DRHOX(2*I-1,2*J-1) DRHOX(2*I ,2*J-1) = LAMBDA*AIMAG(DF(I,J)) + ONEML*AIMAG(DG(I,J)*GAMMA) DRHOX(2*I-1,2*J ) = -DRHOX(2*I,2*J-1) END DO END DO DRHOL(1:2*N-1:2) = REAL(F) - REAL(G*GAMMA) DRHOL(2:2*N:2 ) = AIMAG(F) - AIMAG(G*GAMMA) RHOV(1:2*N-1:2) = LAMBDA*REAL(F) + ONEML*REAL(G*GAMMA) RHOV(2:2*N:2 ) = LAMBDA*AIMAG(F) + ONEML*AIMAG(G*GAMMA) RETURN END SUBROUTINE RHO !!! SUBROUTINE START_SYSTEM ! START_SYSTEM evaluates the start system G(XC) and the Jacobian matrix ! DG(XC). Arithmetic is complex. ! ! On exit: ! ! G(:) contains the complex N-dimensional start system evaluated at XC(:). ! ! DG(:,:) contains the complex N-by-N-dimensional Jacobian matrix of ! the start system evaluted at XC(:). ! Local variables. IMPLICIT NONE INTEGER:: I, J, K, L COMPLEX (KIND=R8):: TEMP ! TEMP1G AND TEMP2G are employed to reduce recalculation in G and DG. ! Note: If SD(I,J)=0, then the corresponding factor is 1, not 0. TEMP1G = (0.0_R8,0.0_R8) TEMP2G = (0.0_R8,0.0_R8) DO I=1,N DO J=1,PARTITION_SIZES(I) IF (PARTITION(I)%SET(J)%SET_DEG == 0) THEN TEMP2G(I,J) = (1.0_R8,0.0_R8) ELSE K = PARTITION(I)%SET(J)%NUM_INDICES TEMP1G(I,J) = SUM( PARTITION(I)%SET(J)%START_COEF(1:K)* & XC(PARTITION(I)%SET(J)%INDEX(1:K)) ) TEMP2G(I,J) = TEMP1G(I,J)**PARTITION(I)%SET(J)%SET_DEG - & XC(N+1)**PARTITION(I)%SET(J)%SET_DEG END IF END DO G(I) = PRODUCT(TEMP2G(I,1:PARTITION_SIZES(I))) END DO ! Calculate the derivative of G with respect to XC(1),...,XC(N) ! in 3 steps. ! STEP 1: First treat XC(N+1) as an independent variable. DG = (0.0_R8,0.0_R8) DO I=1,N DO J=1,PARTITION_SIZES(I) IF (PARTITION(I)%SET(J)%SET_DEG == 0) CYCLE K = PARTITION(I)%SET(J)%NUM_INDICES DG(I,PARTITION(I)%SET(J)%INDEX(1:K)) = PARTITION(I)%SET(J)%SET_DEG * & PARTITION(I)%SET(J)%START_COEF(1:K) * & (TEMP1G(I,J)**(PARTITION(I)%SET(J)%SET_DEG - 1)) TEMP = (1.0_R8,0.0_R8) DO L=1,PARTITION_SIZES(I) IF (L == J) CYCLE TEMP = TEMP * TEMP2G(I,L) END DO DG(I,PARTITION(I)%SET(J)%INDEX(1:K)) = & DG(I,PARTITION(I)%SET(J)%INDEX(1:K)) * TEMP END DO END DO ! STEP 2: Now calculate the N-by-1 Jacobian matrix of G with ! respect to XC(N+1) using the product rule. DO I=1,N DO J=1,PARTITION_SIZES(I) IF (PARTITION(I)%SET(J)%SET_DEG == 0) CYCLE TEMP = -PARTITION(I)%SET(J)%SET_DEG * & (XC(N+1)**(PARTITION(I)%SET(J)%SET_DEG - 1)) DO K=1,PARTITION_SIZES(I) IF (K == J) CYCLE TEMP = TEMP*TEMP2G(I,K) END DO DG(I,N+1) = DG(I,N+1) + TEMP END DO END DO ! STEP 3: Use the chain rule with XC(N+1) considered as a function ! of XC(1),...,XC(N). DO I=1,N DG(I,1:N) = DG(I,1:N) + DG(I,N+1) * PROJ_COEF(1:N) END DO RETURN END SUBROUTINE START_SYSTEM !!! SUBROUTINE TARGET_SYSTEM ! TARGET_SYSTEM calculates the target system F(XC) and the Jacobian matrix ! DF(XC). Arithmetic is complex. ! ! On exit: ! ! F(:) contains the complex N-dimensional target system evaluated ! at XC(:). ! ! DF(:,:) is the complex N-by-N-dimensional Jacobian matrix of the ! target system evaluated at XC(:). ! Local variables. IMPLICIT NONE INTEGER:: I, J, K, L COMPLEX (KIND=R8):: T, TS ! Evaluate F(XC). For efficiency, indexing functions and array sections ! are avoided. DO I=1,N TS = (0.0_R8, 0.0_R8) DO J=1,POLYNOMIAL(I)%NUM_TERMS T = POLYNOMIAL(I)%TERM(J)%COEF DO K=1,N+1 IF (POLYNOMIAL(I)%TERM(J)%DEG(K) == 0) CYCLE T = T * XC(K)**POLYNOMIAL(I)%TERM(J)%DEG(K) END DO TS = TS + T END DO F(I) = TS END DO ! Calulate the Jacobian matrix DF(XC). DF = (0.0_R8,0.0_R8) DO I=1,N DO J=1,N+1 TS = (0.0_R8,0.0_R8) DO K=1,POLYNOMIAL(I)%NUM_TERMS IF (POLYNOMIAL(I)%TERM(K)%DEG(J) == 0) CYCLE T = POLYNOMIAL(I)%TERM(K)%COEF * POLYNOMIAL(I)%TERM(K)%DEG(J) * & (XC(J)**(POLYNOMIAL(I)%TERM(K)%DEG(J) - 1)) DO L=1,N+1 IF ((L == J) .OR. (POLYNOMIAL(I)%TERM(K)%DEG(L) == 0)) CYCLE T = T * (XC(L)**POLYNOMIAL(I)%TERM(K)%DEG(L)) END DO TS = TS + T END DO DF(I,J) = TS END DO END DO ! Convert DF to partials with respect to XC(1),...,XC(N) by ! applying the chain rule with XC(N+1) considered as a function ! of XC(1),...,XC(N). DO I=1,N DF(I,1:N) = DF(I,1:N) + PROJ_COEF(1:N) * DF(I,N+1) END DO RETURN END SUBROUTINE TARGET_SYSTEM !!! SUBROUTINE OUTPUT_PLP ! OUTPUT_PLP first untransforms (converts from projective to affine ! coordinates) and then unscales a root. ! ! On entry: ! ! XC(1:N) contains a root in projective coordinates, with the (N+1)st ! projective coordinate XC(N+1) implicitly defined by the ! projective transformation. ! ! On exit: ! ! XC(1:N) contains the untransformed (affine), unscaled root. ! ! XC(N+1) is the homogeneous coordinate of the root of the scaled ! target system, if scaling was performed. IMPLICIT NONE INTEGER:: I REAL (KIND=R8), PARAMETER:: BIG=HUGE(1.0_R8) ! Calculate the homogeneous coordinate XC(N+1) using the vector XC(1:N) ! with the projective transformation, then untransform XC(1:N) (convert ! to affine coordinates). XC(N+1) = SUM(PROJ_COEF(1:N)*XC(1:N)) + PROJ_COEF(N+1) ! Deal carefully with solutions at infinity. IF (ABS(XC(N+1)) < 1.0_R8) THEN DO I=1,N IF (ABS(XC(I)) >= BIG*ABS(XC(N+1))) THEN XC(I) = CMPLX(BIG,BIG,KIND=R8) ! Solution at infinity. ELSE XC(I) = XC(I)/XC(N+1) END IF END DO ELSE XC(1:N) = XC(1:N)/XC(N+1) END IF ! Unscale the variables. IF (.NOT. PRESENT(NO_SCALING)) THEN DO I=1,N IF (REAL(XC(I)) /= BIG) XC(I) = XC(I)*(10.0_R8**SCALE_FACTORS(I)) END DO END IF RETURN END SUBROUTINE OUTPUT_PLP END SUBROUTINE POLSYS_PLP !!! SUBROUTINE BEZOUT_PLP(N,MAXT,TOL,BPLP) ! ! BEZOUT_PLP calculates and returns only the generalized Bezout number ! BPLP of the target polynomial system, based on the variable partition ! P defined in the module GLOBAL_PLP. BEZOUT_PLP finds BPLP very ! quickly, which is useful for exploring alternative partitions. ! ! Calls SINGSYS_PLP. ! ! On input: ! ! N is the dimension of the target system. ! ! MAXT is the maximum number of terms in any component of the target ! system. MAXT = MAX((/(NUMT(I),I=1,N)/)). ! ! TOL is the singularity test threshold used by SINGSYS_PLP. If ! TOL <= 0.0 on input, TOL is reset to the default value ! SQRT(EPSILON(1.0_R8)). ! ! GLOBAL_PLP allocatable objects POLYNOMIAL, PARTITION_SIZES, and ! PARTITION (see GLOBAL_PLP documentation) must be allocated and ! defined in the calling program. ! ! On output: ! ! N and MAXT are unchanged, and TOL may have been changed as described ! above. ! ! BPLP is the generalized Bezout number for the target system based on ! the variable partition P defined in the module GLOBAL_PLP. USE GLOBAL_PLP IMPLICIT NONE INTEGER, INTENT(IN):: N, MAXT REAL (KIND=R8), INTENT(IN OUT):: TOL INTEGER, INTENT(OUT):: BPLP !INTERFACE ! SUBROUTINE SINGSYS_PLP(N,LEX_NUM,LEX_SAVE,TOL,RAND_MAT,MAT,NONSING) ! USE GLOBAL_PLP ! INTEGER, INTENT(IN):: N ! INTEGER, DIMENSION(N), INTENT(IN OUT):: LEX_NUM,LEX_SAVE ! REAL (KIND=R8), INTENT(IN):: TOL ! REAL (KIND=R8), DIMENSION(N,N), INTENT(IN):: RAND_MAT ! REAL (KIND=R8), DIMENSION(N+1,N), INTENT(IN OUT):: MAT ! LOGICAL, INTENT(OUT):: NONSING ! END SUBROUTINE SINGSYS_PLP !END INTERFACE ! Local variables. INTEGER:: I, J, K, L INTEGER, DIMENSION(MAXT):: DHOLD INTEGER, DIMENSION(N):: LEX_NUM, LEX_SAVE REAL (KIND=R8), DIMENSION(N+1,N):: MAT REAL (KIND=R8), DIMENSION(N,N):: RAND_MAT REAL, DIMENSION(N,N):: RANDNUMS LOGICAL:: NONSING ! Set default value for singularity threshold TOL. IF (TOL <= REAL(N,KIND=R8)*EPSILON(1.0_R8)) TOL = SQRT(EPSILON(1.0_R8)) ! Initialize RAND_MAT with random numbers uniformly distributed in ! [-1,-1/2] union [1/2,1]. CALL RANDOM_SEED CALL RANDOM_NUMBER(HARVEST=RANDNUMS) RANDNUMS = RANDNUMS - 0.5 + SIGN(0.5, RANDNUMS - 0.5) RAND_MAT = REAL(RANDNUMS,KIND=R8) ! Calculate set degrees of the variable partition P. DHOLD = 0 DO I=1,N DO J=1,PARTITION_SIZES(I) DO K=1,NUMV(I,J) DHOLD(1:NUMT(I)) = (/(D(I,L,PAR(I,J,K)),L=1,NUMT(I))/)+DHOLD(1:NUMT(I)) END DO PARTITION(I)%SET(J)%SET_DEG = MAXVAL(DHOLD(1:NUMT(I))) DHOLD = 0 END DO END DO ! Compute Bezout number using lexicographic ordering. BPLP = 0 LEX_NUM(1:N-1) = 1 LEX_NUM(N) = 0 LEX_SAVE = 0 MAIN_LOOP: DO DO J=N,1,-1 IF (LEX_NUM(J) < PARTITION_SIZES(J)) THEN L = J EXIT END IF END DO LEX_NUM(L) = LEX_NUM(L) + 1 IF (L + 1 <= N) LEX_NUM(L+1:N) = 1 ! Test singularity of start subsystem corresponding to lexicographic ! vector LEX_NUM. CALL SINGSYS_PLP(N,LEX_NUM,LEX_SAVE,TOL,RAND_MAT,MAT,NONSING) IF (NONSING) BPLP = BPLP + PRODUCT((/(SD(K,LEX_NUM(K)),K=1,N)/)) IF (ALL(LEX_NUM == PARTITION_SIZES)) EXIT END DO MAIN_LOOP RETURN END SUBROUTINE BEZOUT_PLP !!! SUBROUTINE SINGSYS_PLP(N,LEX_NUM,LEX_SAVE,TOL,RAND_MAT,MAT,NONSING) ! ! SINGSYS_PLP determines if the subsystem of the start system ! corresponding to the lexicographic vector LEX_NUM is nonsingular, ! or if a family of subsystems of the start system defined by ! LEX_NUM and LEX_SAVE is singular, by using Householder reflections and ! tree pruning. Using the notation defined in the module GLOBAL_PLP, ! the vector LEX_NUM defines a linear system of equations ! L(1,LEX_NUM(1)) = constant_1 ! . ! . ! . ! L(N,LEX_NUM(N)) = constant_N ! which, if nonsingular for generic coefficients, defines ! PRODUCT((/ (SD(K,LEX_NUM(K)), K=1,N) /)) nonsingular starting points ! for homotopy paths. Nonsingularity of a generic coefficient matrix is ! checked by computing a QR decomposition of the transpose of the ! coefficient matrix. Observe that if the first J rows are rank ! deficient, then all lexicographic vectors (LEX_NUM(1:J), *) also ! correspond to singular systems, and thus the tree of all possible ! lexicographic orderings can be pruned. ! ! The QR factorization is maintained as a product of Householder ! reflections, and updated based on the difference between LEX_SAVE ! (the value of LEX_NUM returned from the previous call to SINGSYS_PLP) ! and the current input LEX_NUM. LEX_SAVE and LEX_NUM together ! implicitly define a family of subsystems, namely, all those ! corresponding to lexicographic orderings with head LEX_NUM(1:J), ! where J is the smallest index such that LEX_SAVE(J) /= LEX_NUM(J). ! ! Calls LAPACK subroutines DLARFX and DLARFG. ! ! On input: ! ! N is the dimension of the start and target systems. ! ! LEX_NUM(1:N) is a lexicographic vector which specifies a particular ! subsystem (and with LEX_SAVE a family of subsystems) of the start ! system. ! ! LEX_SAVE(1:N) holds the value of LEX_NUM returned from the previous ! call, and should not be changed between calls to SINGSYS_PLP. Set ! LEX_SAVE=0 on the first call to SINGSYS_PLP. ! ! TOL is the singularity test threshold. The family of subsystems ! corresponding to lexicographic vectors (LEX_NUM(1:J), *) is declared ! singular if ABS(R(J,J)) < TOL for the QR factorization of a generic ! start system coefficient matrix. ! ! RAND_MAT(N,N) is a random matrix with entries uniformly distributed ! in [-1,-1/2] union [1/2,1], used to seed the random generic ! coefficient matrix MAT. RAND_MAT should not change between calls to ! SINGSYS_PLP. ! ! On output: ! ! LEX_NUM is unchanged if NONSING=.TRUE. If NONSING=.FALSE., ! LEX_NUM(1:J) is unchanged, and ! LEX_NUM(J+1:N) = PARTITION_SIZES(J+1:N), where J is the smallest ! index such that ABS(R(J,J)) < TOL for the QR factorization of the ! generic start system coefficient matrix corresponding to LEX_NUM ! (on input). ! ! LEX_SAVE = LEX_NUM. ! ! NONSING = .TRUE. if the subsystem of the start system defined by ! LEX_NUM is nonsingular. NONSING = .FALSE. otherwise, which means that ! the entire family of subsystems corresponding to lexicographic vectors ! (LEX_NUM(1:J), *) is singular, where J is the smallest index such that ! ABS(R(J,J)) < TOL for the QR factorization of the generic start system ! coefficient matrix corresponding to LEX_NUM (on input). ! ! Working storage: ! ! MAT(N+1,N) is updated on successive calls to SINGSYS_PLP, and should ! not be changed by the calling program. MAT can be undefined on the ! first call to SINGSYS_PLP (when LEX_SAVE = 0). Define J as the ! smallest index where LEX_SAVE(J) /= LEX_NUM(J). Upon exit after a ! subsequent call, for some M >= J, MAT contains, in the first M columns, ! a partial QR factorization stored as a product of Householder ! reflections, and, in the last N-M columns, random numbers that define ! the subsystem of the start system corresponding to the lexicographic ! vector LEX_NUM. For 1<=K<=M, V(2:N+1-K)=MAT(K+1:N,K), V(1)=1, together ! with TAU=MAT(N+1,K), define a Householder reflection of dimension ! N+1-K. USE GLOBAL_PLP IMPLICIT NONE INTEGER, INTENT(IN):: N INTEGER, DIMENSION(N), INTENT(IN OUT):: LEX_NUM, LEX_SAVE REAL (KIND=R8), INTENT(IN):: TOL REAL (KIND=R8), DIMENSION(N,N), INTENT(IN):: RAND_MAT REAL (KIND=R8), DIMENSION(N+1,N), INTENT(IN OUT):: MAT LOGICAL, INTENT(OUT):: NONSING ! Local variables. INTEGER:: I, J, K REAL (KIND=R8), DIMENSION(N):: V REAL (KIND=R8):: WORK(1) IF (N == 1) THEN LEX_SAVE = LEX_NUM NONSING = .TRUE. RETURN END IF ! (Re)set MAT (in column form) from LEX_NUM. DO I=1,N IF (LEX_SAVE(I) /= LEX_NUM(I)) THEN LEX_SAVE(I+1:N) = 0 DO K=I,N MAT(1:N+1,K) = 0.0_R8 DO J=1,NUMV(K,LEX_NUM(K)) MAT(PAR(K,LEX_NUM(K),J),K) = RAND_MAT(PAR(K,LEX_NUM(K),J),K) END DO END DO EXIT END IF END DO ! Recompute QR factorization of MAT starting where first change in ! LEX_NUM occurred. NONSING = .FALSE. IF (LEX_SAVE(1) /= LEX_NUM(1)) THEN ! Skip QR factorization and prune tree if this set degree = 0. IF (SD(1,LEX_NUM(1)) == 0) THEN LEX_NUM(2:N) = PARTITION_SIZES(2:N) LEX_SAVE = LEX_NUM RETURN ELSE CALL DLARFG(N,MAT(1,1),MAT(2:N,1),1,MAT(N+1,1)) END IF END IF DO J=2,N IF (LEX_SAVE(J) /= LEX_NUM(J)) THEN ! Skip rest of QR factorization and prune tree if this set degree = 0. IF (SD(J,LEX_NUM(J)) == 0) THEN IF (J < N) LEX_NUM(J+1:N) = PARTITION_SIZES(J+1:N) EXIT END IF DO K=1,J-1 V(K) = 1.0_R8 V(K+1:N) = MAT(K+1:N,K) CALL DLARFX('L',N-K+1,1,V(K:N),MAT(N+1,K),MAT(K:N,J),N-K+1,WORK) END DO IF (J < N) CALL DLARFG(N-J+1,MAT(J,J),MAT(J+1:N,J),1,MAT(N+1,J)) ! Check singularity of subsystem corresponding to lexicographic ! vector (LEX_NUM(1:J), *). IF (ABS(MAT(J,J)) < TOL) THEN IF (J < N) LEX_NUM(J+1:N) = PARTITION_SIZES(J+1:N) EXIT END IF END IF ! Subsystem corresponding to LEX_NUM is nonsingular when J==N here. IF (J == N) NONSING = .TRUE. END DO ! Save updated LEX_NUM for next call. LEX_SAVE = LEX_NUM RETURN END SUBROUTINE SINGSYS_PLP END MODULE POLSYS !!! ! ---------------------------------------------------------------------- ! ! The following modules and external subroutines are from HOMPACK90. ! This module provides global allocatable arrays used for the sparse ! matrix data structures, and by the polynomial system solver. The ! MODULE HOMOTOPY uses this module. ! MODULE HOMPACK90_GLOBAL USE REAL_PRECISION INTEGER, DIMENSION(:), ALLOCATABLE:: COLPOS, IPAR, ROWPOS REAL (KIND=R8), DIMENSION(:), ALLOCATABLE:: PAR, PP, QRSPARSE END MODULE HOMPACK90_GLOBAL MODULE HOMOTOPY ! Interfaces for user written subroutines. USE REAL_PRECISION, ONLY : R8 USE HOMPACK90_GLOBAL ! ! Interface for subroutine that evaluates F(X) and returns it in the vector V. INTERFACE SUBROUTINE F(X,V) USE REAL_PRECISION REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V END SUBROUTINE F END INTERFACE ! ! Interface for subroutine that returns in V the K-th column of the Jacobian ! matrix of F(X) evaluated at X. INTERFACE SUBROUTINE FJAC(X,V,K) USE REAL_PRECISION REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V INTEGER, INTENT(IN):: K END SUBROUTINE FJAC END INTERFACE ! ! Interface for subroutine that evaluates RHO(A,LAMBDA,X) and returns it ! in the vector V. INTERFACE SUBROUTINE RHO(A,LAMBDA,X,V) USE REAL_PRECISION REAL (KIND=R8), INTENT(IN):: A(:),X(:) REAL (KIND=R8), INTENT(IN OUT):: LAMBDA REAL (KIND=R8), INTENT(OUT):: V(:) END SUBROUTINE RHO END INTERFACE ! The following code is specifically for the polynomial system driver ! POLSYS1H, and should be used verbatim with POLSYS1H in the external ! subroutine RHO. ! USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR ! FOR POLSYS1H ONLY. ! INTERFACE ! SUBROUTINE HFUNP(N,A,LAMBDA,X) ! USE REAL_PRECISION ! INTEGER, INTENT(IN):: N ! REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N) ! END SUBROUTINE HFUNP ! END INTERFACE ! INTEGER:: J,NPOL ! FORCE PREDICTED POINT TO HAVE LAMBDA .GE. 0 . ! IF (LAMBDA .LT. 0.0) LAMBDA=0.0 ! NPOL=IPAR(1) ! CALL HFUNP(NPOL,A,LAMBDA,X) ! DO J=1,2*NPOL ! V(J)=PAR(IPAR(3 + (4-1)) + (J-1)) ! END DO ! RETURN ! If calling FIXP?? or STEP?? directly, supply appropriate replacement ! code in the external subroutine RHO. ! ! Interface for subroutine that calculates and returns in A the vector ! Z such that RHO(Z,LAMBDA,X) = 0 . INTERFACE SUBROUTINE RHOA(A,LAMBDA,X) USE REAL_PRECISION REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: A REAL (KIND=R8), INTENT(IN):: LAMBDA,X(:) END SUBROUTINE RHOA END INTERFACE ! ! Interface for subroutine that returns in the vector V the Kth column ! of the Jacobian matrix [D RHO/D LAMBDA, D RHO/DX] evaluated at the ! point (A, LAMBDA, X). INTERFACE SUBROUTINE RHOJAC(A,LAMBDA,X,V,K) USE REAL_PRECISION REAL (KIND=R8), INTENT(IN):: A(:),X(:) REAL (KIND=R8), INTENT(IN OUT):: LAMBDA REAL (KIND=R8), INTENT(OUT):: V(:) INTEGER, INTENT(IN):: K END SUBROUTINE RHOJAC END INTERFACE ! The following code is specifically for the polynomial system driver ! POLSYS1H, and should be used verbatim with POLSYS1H in the external ! subroutine RHOJAC. ! USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR ! FOR POLSYS1H ONLY. ! INTERFACE ! SUBROUTINE HFUNP(N,A,LAMBDA,X) ! USE REAL_PRECISION ! INTEGER, INTENT(IN):: N ! REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N) ! END SUBROUTINE HFUNP ! END INTERFACE ! INTEGER:: J,NPOL,N2 ! NPOL=IPAR(1) ! N2=2*NPOL ! IF (K .EQ. 1) THEN ! FORCE PREDICTED POINT TO HAVE LAMBDA .GE. 0 . ! IF (LAMBDA .LT. 0.0) LAMBDA=0.0 ! CALL HFUNP(NPOL,A,LAMBDA,X) ! DO J=1,N2 ! V(J)=PAR(IPAR(3 + (6-1)) + (J-1)) ! END DO ! RETURN ! ELSE ! DO J=1,N2 ! V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2)) ! END DO ! ENDIF ! ! RETURN ! If calling FIXP?? or STEP?? directly, supply appropriate replacement ! code in the external subroutine RHOJAC. ! ! ! Interface for subroutine that evaluates a sparse Jacobian matrix of ! F(X) at X, and operates as follows: ! ! If MODE = 1, ! evaluate the N x N symmetric Jacobian matrix of F(X) at X, and return ! the result in packed skyline storage format in QRSPARSE. LENQR is the ! length of QRSPARSE, and ROWPOS contains the indices of the diagonal ! elements of the Jacobian matrix within QRSPARSE. ROWPOS(N+1) and ! ROWPOS(N+2) are set by subroutine FODEDS. The allocatable array COLPOS ! is not used by this storage format. ! ! If MODE = 2, ! evaluate the N x N Jacobian matrix of F(X) at X, and return the result ! in sparse row storage format in QRSPARSE. LENQR is the length of ! QRSPARSE, ROWPOS contains the indices of where each row begins within ! QRSPARSE, and COLPOS (of length LENQR) contains the column indices of ! the corresponding elements in QRSPARSE. Even if zero, the diagonal ! elements of the Jacobian matrix must be stored in QRSPARSE. INTERFACE SUBROUTINE FJACS(X) USE REAL_PRECISION USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X END SUBROUTINE FJACS END INTERFACE ! ! ! Interface for subroutine that evaluates a sparse Jacobian matrix of ! RHO(A,X,LAMBDA) at (A,X,LAMBDA), and operates as follows: ! ! If MODE = 1, ! evaluate the N X N symmetric Jacobian matrix [D RHO/DX] at ! (A,X,LAMBDA), and return the result in packed skyline storage format in ! QRSPARSE. LENQR is the length of QRSPARSE, and ROWPOS contains the ! indices of the diagonal elements of [D RHO/DX] within QRSPARSE. PP ! contains -[D RHO/D LAMBDA] evaluated at (A,X,LAMBDA). Note the minus ! sign in the definition of PP. The allocatable array COLPOS is not used ! in this storage format. ! ! If MODE = 2, ! evaluate the N X (N+1) Jacobian matrix [D RHO/DX, D RHO/DLAMBDA] at ! (A,X,LAMBDA), and return the result in sparse row storage format in ! QRSPARSE. LENQR is the length of QRSPARSE, ROWPOS contains the indices ! of where each row begins within QRSPARSE, and COLPOS (of length LENQR) ! contains the column indices of the corresponding elements in QRSPARSE. ! Even if zero, the diagonal elements of the Jacobian matrix must be ! stored in QRSPARSE. The allocatable array PP is not used in this ! storage format. ! INTERFACE SUBROUTINE RHOJS(A,LAMBDA,X) USE REAL_PRECISION USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS REAL (KIND=R8), INTENT(IN):: A(:),LAMBDA,X(:) END SUBROUTINE RHOJS END INTERFACE END MODULE HOMOTOPY SUBROUTINE STEPNX(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR, & ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR) ! ! STEPNX takes one step along the zero curve of the homotopy map ! using a predictor-corrector algorithm. The predictor uses a Hermite ! cubic interpolant, and the corrector returns to the zero curve along ! the flow normal to the Davidenko flow. STEPNX also estimates a ! step size H for the next step along the zero curve. STEPNX is an ! expert user version of STEPN(F|S), written using the reverse call ! protocol. All matrix data structures and numerical linear algebra ! are the responsibility of the calling program. STEPNX indicates to ! the calling program, via flags, at which points RHO(A,LAMBDA,X) and ! [ D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX ] must be ! evaluated, and what linear algebra must be done with these functions. ! Out of range arguments can also be signaled to STEPNX , which will ! attempt to modify its steplength algorithm to reflect this ! information. ! ! The following interface block should be inserted in the calling ! program: ! ! INTERFACE ! SUBROUTINE STEPNX(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR, ! & ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR) ! USE HOMOTOPY ! USE REAL_PRECISION ! INTEGER, INTENT(IN):: N ! INTEGER, INTENT(IN OUT):: NFE,IFLAG ! LOGICAL, INTENT(IN OUT):: START,CRASH ! REAL (KIND=R8), INTENT(IN OUT):: HOLD,H,RELERR,ABSERR,S,RHOLEN, ! & SSPAR(8) ! REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A ! REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD, ! & TZ,W,WP ! REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: Z0,Z1 ! END SUBROUTINE STEPNX ! END INTERFACE ! ! ON INPUT: ! ! N = dimension of X and the homotopy map. ! ! NFE = number of Jacobian matrix evaluations. ! ! IFLAG = -2, -1, or 0, indicating the problem type, on the first ! call to STEPNX . STEPNX does not distinguish between ! these values, but they are permitted for consistency with ! the rest of HOMPACK. ! ! = 0-10*R, -1-10*R, or -2-10*R, R = 1,2,3, indicate to STEPNX ! where to resume after a reverse call. The calling program ! must not modify IFLAG after a reverse call, except as ! noted next. ! ! = -40, -41, or -42, used for a final call to deallocate working ! storage, after all path tracking is finished. START and ! IFLAG are reset on return. ! ! = -100-10*R, -101-10*R, -102-10*R, R = 1,2,3, indicate to ! STEPNX where to resume after a reverse call, and that the ! requested evaluation point was out of range. STEPNX will ! reduce H and try again. ! ! START = .TRUE. on first call to STEPNX , .FALSE. otherwise. ! ! HOLD = ||Y - YOLD||; should not be modified by the user. ! ! H = upper limit on length of step that will be attempted. H must be ! set to a positive number on the first call to STEPNX . ! Thereafter STEPNX calculates an optimal value for H , and H ! should not be modified by the user. ! ! RELERR, ABSERR = relative and absolute error values. The iteration is ! considered to have converged when a point W=(LAMBDA,X) is found ! such that ! ! ||Z|| <= RELERR*||W|| + ABSERR , where ! ! Z is the Newton step to W=(LAMBDA,X). ! ! S = (approximate) arc length along the homotopy zero curve up to ! Y(S) = (LAMBDA(S), X(S)). ! ! Y(1:N+1) = previous point (LAMBDA(S), X(S)) found on the zero curve of ! the homotopy map. ! ! YP(1:N+1) = unit tangent vector to the zero curve of the homotopy map ! at Y . ! ! YOLD(1:N+1) = a point before Y on the zero curve of the homotopy map. ! ! YPOLD(1:N+1) = unit tangent vector to the zero curve of the homotopy ! map at YOLD . ! ! A(:) = parameter vector in the homotopy map. ! ! TZ(1:N+1), W(1:N+1), and WP(1:N+1) are work arrays used for the ! Newton step calculation and the interpolation. On reentry after ! a reverse call, WP and TZ contain the tangent vector and ! Newton step, respectively, at the point W . Precisely, ! D RHO(A,W)/DW WP = 0, WP^T YP > 0, ||WP|| = 1, ! and TZ is the minimum norm solution of ! D RHO(A,W)/DW TZ = - RHO(A,W). ! ! RHOLEN = ||RHO(A,W)||_2 is required by some reverse calls. ! ! SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P) is ! a vector of parameters used for the optimal step size estimation. ! If SSPAR(J) .LE. 0.0 on input, it is reset to a default value ! by STEPNX . Otherwise the input value of SSPAR(J) is used. ! See the comments below in STEPNX for more information about ! these constants. ! ! ! ON OUTPUT: ! ! N and A are unchanged. ! ! NFE has been updated. ! ! IFLAG ! = -22, -21, -20, -32, -31, or -30 requests the calling program to ! return the unit tangent vector in WP , the normal flow Newton ! step in TZ , and the 2-norm of the homotopy map in RHOLEN , ! all evaluated at the point W . ! ! = -12, -11, or -10 requests the calling program to return in WP ! the unit tangent vector at W . ! ! = -2, -1, or 0 (unchanged) on a normal return after a successful ! step. ! ! = 4 if a Jacobian matrix with rank < N has occurred. The ! iteration was not completed. ! ! = 6 if the iteration failed to converge. W contains the last ! Newton iterate. ! ! = 7 if input arguments or array sizes are invalid, or IFLAG was ! changed during a reverse call. ! ! START = .FALSE. on a normal return. ! ! CRASH ! = .FALSE. on a normal return. ! ! = .TRUE. if the step size H was too small. H has been ! increased to an acceptable value, with which STEPNX may be ! called again. ! ! = .TRUE. if RELERR and/or ABSERR were too small. They have ! been increased to acceptable values, with which STEPNX may ! be called again. ! ! HOLD = ||Y - YOLD||. ! ! H = optimal value for next step to be attempted. Normally H should ! not be modified by the user. ! ! RELERR, ABSERR are unchanged on a normal return. ! ! S = (approximate) arc length along the zero curve of the homotopy map ! up to the latest point found, which is returned in Y . ! ! Y, YP, YOLD, YPOLD contain the two most recent points and tangent ! vectors found on the zero curve of the homotopy map. ! ! SSPAR may have been changed to default values. ! ! ! Z0(1:N+1), Z1(1:N+1) are allocatable work arrays used for the ! estimation of the next step size H . ! ! Calls DNRM2 . ! USE HOMOTOPY USE REAL_PRECISION INTEGER, INTENT(IN):: N INTEGER, INTENT(IN OUT):: NFE,IFLAG LOGICAL, INTENT(IN OUT):: START,CRASH REAL (KIND=R8), INTENT(IN OUT):: HOLD,H,RELERR,ABSERR,S,RHOLEN, & SSPAR(8) REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD, & TZ,W,WP REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: Z0,Z1 ! ! ***** LOCAL VARIABLES. ***** ! REAL (KIND=R8), SAVE:: DCALC,DELS,F0,F1,FOURU,FP0,FP1, & HFAIL,HT,LCALC,RCALC,TEMP,TWOU INTEGER, SAVE:: IFLAGC,ITNUM,J,JUDY,NP1 LOGICAL, SAVE:: FAIL ! ! ***** END OF SPECIFICATION INFORMATION. ***** ! ! THE LIMIT ON THE NUMBER OF NEWTON ITERATIONS ALLOWED BEFORE REDUCING ! THE STEP SIZE H MAY BE CHANGED BY CHANGING THE FOLLOWING PARAMETER ! STATEMENT: INTEGER, PARAMETER:: LITFH=4 ! ! DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. ! REAL (KIND=R8):: DD001,DD0011,DD01,DD011,DNRM2,QOFS DD01(F0,F1,DELS)=(F1-F0)/DELS DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) - & DD001(F0,FP0,F1,DELS))/DELS QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) + & DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0 ! ! NP1=N+1 IF (IFLAG > 0) RETURN IF ((START .AND. IFLAG < -2) .OR. SIZE(Y) /= NP1 .OR. & SIZE(YP) /= NP1 .OR. SIZE(YOLD) /= NP1 .OR. & SIZE(YPOLD) /= NP1 .OR. SIZE(TZ) /= NP1 .OR. & SIZE(W) /= NP1 .OR. SIZE(WP) /= NP1 .OR. & (.NOT. START .AND. -MOD(-IFLAG,100) /= IFLAGC .AND. & ABS(IFLAG)/10 /= 4)) THEN IFLAG=7 RETURN ENDIF IFLAGC=-MOD(-IFLAG,10) ! ! PICK UP EXECUTION WEHRE IT LEFT OFF AFTER A REVERSE CALL. ! IF (IFLAG < -2) THEN GO TO (50,100,400,700), MOD(ABS(IFLAG),100)/10 ENDIF TWOU=2.0*EPSILON(1.0_R8) FOURU=TWOU+TWOU CRASH=.TRUE. ! THE ARCLENGTH S MUST BE NONNEGATIVE. IF (S .LT. 0.0) RETURN ! IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE. IF (H .LT. FOURU*(1.0+S)) THEN H=FOURU*(1.0+S) RETURN ENDIF ! IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE VALUES. TEMP=DNRM2(NP1,Y,1)+1.0 IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN IF (RELERR .NE. 0.0) THEN RELERR=FOURU*(1.0+FOURU) ABSERR=MAX(ABSERR,0.0_R8) ELSE ABSERR=FOURU*TEMP ENDIF RETURN ENDIF CRASH=.FALSE. IF (.NOT. START) GO TO 300 ! ! ***** STARTUP SECTION (FIRST STEP ALONG ZERO CURVE). ***** ! FAIL=.FALSE. START=.FALSE. IF (ALLOCATED(Z0)) DEALLOCATE(Z0) IF (ALLOCATED(Z1)) DEALLOCATE(Z1) ALLOCATE(Z0(NP1),Z1(NP1)) ! ! SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS. ! LET Z[K] DENOTE THE NEWTON ITERATES ALONG THE FLOW NORMAL TO THE ! DAVIDENKO FLOW AND Y THEIR LIMIT. ! IDEAL CONTRACTION FACTOR: ||Z[2] - Z[1]|| / ||Z[1] - Z[0]|| IF (SSPAR(1) .LE. 0.0) SSPAR(1)= .5 ! IDEAL RESIDUAL FACTOR: ||RHO(A, Z[1])|| / ||RHO(A, Z[0])|| IF (SSPAR(2) .LE. 0.0) SSPAR(2)= .01 ! IDEAL DISTANCE FACTOR: ||Z[1] - Y|| / ||Z[0] - Y|| IF (SSPAR(3) .LE. 0.0) SSPAR(3)= .5 ! MINIMUM STEP SIZE HMIN . IF (SSPAR(4) .LE. 0.0) SSPAR(4)=(SQRT(N+1.0)+4.0)*EPSILON(1.0_R8) ! MAXIMUM STEP SIZE HMAX . IF (SSPAR(5) .LE. 0.0) SSPAR(5)= 1.0 ! MINIMUM STEP SIZE REDUCTION FACTOR BMIN . IF (SSPAR(6) .LE. 0.0) SSPAR(6)= .1_R8 ! MAXIMUM STEP SIZE EXPANSION FACTOR BMAX . IF (SSPAR(7) .LE. 0.0) SSPAR(7)= 3.0 ! ASSUMED OPERATING ORDER P . IF (SSPAR(8) .LE. 0.0) SSPAR(8)= 2.0 ! ! DETERMINE SUITABLE INITIAL STEP SIZE. H=MIN(H, .10_R8, SQRT(SQRT(RELERR*TEMP+ABSERR))) ! USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION. YPOLD(1)=1.0 YPOLD(2:NP1)=0.0 ! REQUEST TANGENT VECTOR AT Y VIA REVERSE CALL. W=Y YP=YPOLD IFLAG=IFLAGC-10 IFLAGC=IFLAG NFE=NFE+1 RETURN 50 YP=WP ! IF THE STARTING POINT IS OUT OF RANGE, GIVE UP. IF (IFLAG .LE. -100) THEN IFLAG=6 RETURN ENDIF 70 W=Y + H*YP Z0=W JUDY=1 ! DO JUDY=1,LITFH 80 IF (JUDY > LITFH) GO TO 200 ! REQUEST THE CALCULATION OF THE NEWTON STEP TZ AT THE CURRENT ! POINT W VIA REVERSE CALL. IFLAG=IFLAGC-20 IFLAGC=IFLAG NFE=NFE+1 RETURN 100 IF (IFLAG .LE. -100) GO TO 200 ! ! TAKE NEWTON STEP AND CHECK CONVERGENCE. W=W + TZ ITNUM=JUDY ! COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION. IF (JUDY .EQ. 1) THEN LCALC=DNRM2(NP1,TZ,1) RCALC=RHOLEN Z1=W ELSE IF (JUDY .EQ. 2) THEN LCALC=DNRM2(NP1,TZ,1)/LCALC RCALC=RHOLEN/RCALC ENDIF ! GO TO MOP-UP SECTION AFTER CONVERGENCE. IF (DNRM2(NP1,TZ,1) .LE. RELERR*DNRM2(NP1,W,1)+ABSERR) & GO TO 600 ! JUDY=JUDY+1 GO TO 80 ! END DO ! ! NO CONVERGENCE IN LITFH ITERATIONS. REDUCE H AND TRY AGAIN. 200 IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG=6 RETURN ENDIF H=.5 * H GO TO 70 ! ! ***** END OF STARTUP SECTION. ***** ! ! ***** PREDICTOR SECTION. ***** ! 300 FAIL=.FALSE. ! COMPUTE POINT PREDICTED BY HERMITE INTERPOLANT. USE STEP SIZE H ! COMPUTED ON LAST CALL TO STEPNX . 320 DO J=1,NP1 W(J)=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H) END DO Z0=W ! ! ***** END OF PREDICTOR SECTION. ***** ! ! ***** CORRECTOR SECTION. ***** ! JUDY=1 ! CORRECTOR: DO JUDY=1,LITFH 350 IF (JUDY > LITFH) GO TO 500 ! REQUEST THE CALCULATION OF THE NEWTON STEP TZ AT THE CURRENT ! POINT W VIA REVERSE CALL. IFLAG=IFLAGC-30 IFLAGC=IFLAG NFE=NFE+1 RETURN 400 IF (IFLAG .LE. -100) GO TO 500 ! ! TAKE NEWTON STEP AND CHECK CONVERGENCE. W=W + TZ ITNUM=JUDY ! COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION. IF (JUDY .EQ. 1) THEN LCALC=DNRM2(NP1,TZ,1) RCALC=RHOLEN Z1=W ELSE IF (JUDY .EQ. 2) THEN LCALC=DNRM2(NP1,TZ,1)/LCALC RCALC=RHOLEN/RCALC ENDIF ! GO TO MOP-UP SECTION AFTER CONVERGENCE. IF (DNRM2(NP1,TZ,1) .LE. RELERR*DNRM2(NP1,W,1)+ABSERR) & GO TO 600 ! JUDY=JUDY+1 GO TO 350 ! END DO CORRECTOR ! ! NO CONVERGENCE IN LITFH ITERATIONS. RECORD FAILURE AT CALCULATED H , ! SAVE THIS STEP SIZE, REDUCE H AND TRY AGAIN. 500 FAIL=.TRUE. HFAIL=H IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG=6 RETURN ENDIF H=.5 * H GO TO 320 ! ! ***** END OF CORRECTOR SECTION. ***** ! ! ***** MOP-UP SECTION. ***** ! ! YOLD AND Y ALWAYS CONTAIN THE LAST TWO POINTS FOUND ON THE ZERO ! CURVE OF THE HOMOTOPY MAP. YPOLD AND YP CONTAIN THE TANGENT ! VECTORS TO THE ZERO CURVE AT YOLD AND Y , RESPECTIVELY. ! 600 YPOLD=YP YOLD=Y Y=W YP=WP W=Y - YOLD ! UPDATE ARC LENGTH. HOLD=DNRM2(NP1,W,1) S=S+HOLD ! ! ***** END OF MOP-UP SECTION. ***** ! ! ***** OPTIMAL STEP SIZE ESTIMATION SECTION. ***** ! ! CALCULATE THE DISTANCE FACTOR DCALC . TZ=Z0 - Y W=Z1 - Y DCALC=DNRM2(NP1,TZ,1) IF (DCALC .NE. 0.0) DCALC=DNRM2(NP1,W,1)/DCALC ! ! THE OPTIMAL STEP SIZE HBAR IS DEFINED BY ! ! HT=HOLD * [MIN(LIDEAL/LCALC, RIDEAL/RCALC, DIDEAL/DCALC)]**(1/P) ! ! HBAR = MIN [ MAX(HT, BMIN*HOLD, HMIN), BMAX*HOLD, HMAX ] ! ! IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, SET THE CONTRACTION ! FACTOR LCALC TO ZERO. IF (ITNUM .EQ. 1) LCALC = 0.0 ! FORMULA FOR OPTIMAL STEP SIZE. IF (LCALC+RCALC+DCALC .EQ. 0.0) THEN HT = SSPAR(7) * HOLD ELSE HT = (1.0/MAX(LCALC/SSPAR(1), RCALC/SSPAR(2), DCALC/SSPAR(3))) & **(1.0/SSPAR(8)) * HOLD ENDIF ! HT CONTAINS THE ESTIMATED OPTIMAL STEP SIZE. NOW PUT IT WITHIN ! REASONABLE BOUNDS. H=MIN(MAX(HT,SSPAR(6)*HOLD,SSPAR(4)), SSPAR(7)*HOLD, SSPAR(5)) IF (ITNUM .EQ. 1) THEN ! IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, DON'T DECREASE H . H=MAX(H,HOLD) ELSE IF (ITNUM .EQ. LITFH) THEN ! IF CONVERGENCE REQUIRED THE MAXIMUM LITFH ITERATIONS, DON'T ! INCREASE H . H=MIN(H,HOLD) ENDIF ! IF CONVERGENCE DID NOT OCCUR IN LITFH ITERATIONS FOR A PARTICULAR ! H = HFAIL , DON'T CHOOSE THE NEW STEP SIZE LARGER THAN HFAIL . IF (FAIL) H=MIN(H,HFAIL) ! ! IFLAG=IFLAGC RETURN ! CLEAN UP ALLOCATED WORKING STORAGE. 700 START=.TRUE. IFLAG=IFLAGC IF (ALLOCATED(Z0)) DEALLOCATE(Z0) IF (ALLOCATED(Z1)) DEALLOCATE(Z1) RETURN END SUBROUTINE STEPNX SHAR_EOF fi # end of overwriting check cd .. cd .. cd .. # End of shell archive exit 0